diff options
| author | Igor Pashev <pashev.igor@gmail.com> | 2013-01-28 19:02:21 +0000 |
|---|---|---|
| committer | Igor Pashev <pashev.igor@gmail.com> | 2013-01-28 19:02:21 +0000 |
| commit | f627f77f23d1497c9e1f4269b5c8812d12b42f18 (patch) | |
| tree | 708772d83a8355e25155cf233d5a9e38f8ad4d96 | |
| parent | 6ab0c0f5bf14ed9c15370407b9ee7e0b4b089ae1 (diff) | |
| download | icon-f627f77f23d1497c9e1f4269b5c8812d12b42f18.tar.gz | |
Imported Upstream version 9.5.0upstream/9.5.0upstream
401 files changed, 17810 insertions, 41744 deletions
@@ -1,12 +1,11 @@ -# Makefile for Version 9.4 of Icon +# Makefile for Version 9.5 of Icon # # See doc/install.htm for instructions. # configuration parameters -VERSION=v943 +VERSION=v950 name=unspecified -csw=custom dest=/must/specify/dest/ @@ -39,11 +38,11 @@ config/$(name)/status src/h/define.h: Configure: config/$(name)/status $(MAKE) Pure >/dev/null - cd config; sh setup.sh $(name) NoGraphics $(csw) + cd config; sh setup.sh $(name) NoGraphics X-Configure: config/$(name)/status $(MAKE) Pure >/dev/null - cd config; sh setup.sh $(name) Graphics $(csw) + cd config; sh setup.sh $(name) Graphics # Get the status information for a specific system. @@ -59,24 +58,13 @@ Status: # The interpreter: icont and iconx. -Icont bin/icont: Common - cd src/icont; $(MAKE) - cd src/runtime; $(MAKE) - - -# The compiler: rtt, the run-time system, and iconc. -# (NO LONGER SUPPORTED OR MAINTAINED.) - -Iconc bin/iconc: Common - cd src/runtime; $(MAKE) comp_all - cd src/iconc; $(MAKE) - - -# Common components. - -Common: src/h/define.h +Icont bin/icont: src/h/define.h + uname -a + pwd cd src/common; $(MAKE) cd src/rtt; $(MAKE) + cd src/icont; $(MAKE) + cd src/runtime; $(MAKE) # The Icon program library. @@ -111,11 +99,11 @@ Install: # Bundle up for binary distribution. -DIR=icon.$(VERSION) +DIR=icon-$(VERSION) Package: rm -rf $(DIR) umask 002; $(MAKE) Install dest=$(DIR) - tar cf - icon.$(VERSION) | gzip -9 >icon.$(VERSION).tgz + tar cf - $(DIR) | gzip -9 >$(DIR).tgz rm -rf $(DIR) @@ -126,23 +114,17 @@ Package: Test Test-icont: ; cd tests; $(MAKE) Test Samples Samples-icont: ; cd tests; $(MAKE) Samples -Test-iconc: ; cd tests; $(MAKE) Test-iconc -Samples-iconc: ; cd tests; $(MAKE) Samples-iconc - ################################################################# # # Run benchmarks. -Benchmark: - $(MAKE) Benchmark-icont - -Benchmark-iconc: - cd tests/bench; $(MAKE) benchmark-iconc - -Benchmark-icont: +Benchmark Benchmark-icont: cd tests/bench; $(MAKE) benchmark-icont +Micro Microbench Microbenchmark: + cd tests/bench; $(MAKE) microbenchmark + ################################################################## # @@ -153,14 +135,14 @@ Benchmark-icont: Clean: touch Makedefs - rm -rf icon.* + rm -rf icon-* cd src; $(MAKE) Clean cd ipl; $(MAKE) Clean cd tests; $(MAKE) Clean Pure: touch Makedefs - rm -rf icon.* + rm -rf icon-* rm -rf bin/[abcdefghijklmnopqrstuvwxyz]* rm -rf lib/[abcdefghijklmnopqrstuvwxyz]* cd ipl; $(MAKE) Pure @@ -175,3 +157,6 @@ Pure: Dist-Clean: rm -rf xx `find * -type d -name CVS` rm -f xx `find * -type f | xargs grep -l '<<ARIZONA-[O]NLY>>'` + rm -f xx `find . -type f -name '.??*' ! -name .placeholder` + find . -type d | xargs chmod u=rwx,g=rwsx,o=rx + find . -type f | xargs chmod ug=rw+X,o=r+X @@ -1,18 +1,17 @@ -Icon 9.4.3 README +Icon 9.5.0 README +This directory contains the source code for Version 9.5 of the +Icon programming language. For documentation, see these HTML files: -This directory contains Version 9.4.3 of the Icon programming language. -For documentation, see these HTML files: - + man/man1/icon.1 man(1) page for icon + man/man1/icont.1 man(1) page for icont doc/docguide.htm documentation guide doc/relnotes.htm release notes - doc/install.htm installation instructions (for binary releases) - doc/build.htm build instructions (for source releases) - doc/port.htm porting instructions - doc/files.htm file organization doc/macintosh.htm the Macintosh port doc/cygwin.htm the Cygwin port doc/faq.htm frequently asked questions about Icon + doc/install.htm installation instructions (for binary releases) + doc/build.htm build instructions (for source releases) This material is in the public domain. You may use and copy this material freely. This privilege extends to modifications, although any modified @@ -23,14 +22,5 @@ The responsibility for the use of this material resides entirely with you. We make no warranty of any kind concerning this material, nor do we make any claim as to the suitability of Icon for any application. -For more information or assistance, contact: - +For more information, see the Icon website: www.cs.arizona.edu/icon - icon-project@cs.arizona.edu - - Icon Project - Department of Computer Science - The University of Arizona - P.O. Box 210077 - Tucson, AZ 85721-0077 - U.S.A. diff --git a/config/Makefile b/config/Makefile index 2b17cbd..4f95e8d 100644 --- a/config/Makefile +++ b/config/Makefile @@ -9,4 +9,3 @@ Clean: Pure: rm -f $(TOP)/Makedefs rm -f $(SRC)/h/define.h - rm -f $(SRC)/common/rswitch.[csS] diff --git a/config/aix/rswitch.s b/config/aix/rswitch.s deleted file mode 100644 index 45a1341..0000000 --- a/config/aix/rswitch.s +++ /dev/null @@ -1,52 +0,0 @@ -# coswitch(old, new, first) -# GPR3 GPR4 GPR5 - - .file "rswitch.s" - .extern .new_context{PR} - .extern .syserr{PR} - .globl .coswitch[PR] - .csect .coswitch[PR] - - .set r0, 0 - .set SP, 1 - .set TOC, 2 - .set OLD, 3 - .set NEW, 4 - .set FIRST, 5 - .set RSIZE, 80 # room for regs 13-31, rounded up mod16 - -.coswitch: - stu SP, -RSIZE(SP) # allocate stack frame - - # Save Old Context: - st SP, 0(OLD) # SP - st TOC, 4(OLD) # TOC - mflr r0 - st r0, 8(OLD) # LR (return address) - mfcr r0 - st r0, 12(OLD) # CR - stm 13, -RSIZE(SP) # GPRs 13-31 (save on stack) - - cmpi 0, FIRST, 0 - beq first # if first time - - # Restore new context: - l SP, 0(NEW) # SP - l TOC, 4(NEW) # TOC - l r0, 8(NEW) # LR - mtlr r0 - l r0, 12(NEW) # CR - mtcr r0 - lm 13, -RSIZE(SP) # GPRs 13-31 (from stack) - - ai SP, SP, RSIZE # deallocate stack frame - brl # return into new context - -first: # First-time call: - l SP, 0(NEW) # SP as figured by Icon - ai SP, SP, -64(SP) # save area for callee - cal OLD, 0(r0) # arg1 - cal NEW, 0(r0) # arg2 - bl .new_context{PR} # new_context(0,0) - cal OLD, 0(r0) - bl .syserr{PR} diff --git a/config/bsd/alpha.s b/config/bsd/alpha.s deleted file mode 100644 index 6c9ba72..0000000 --- a/config/bsd/alpha.s +++ /dev/null @@ -1,46 +0,0 @@ -/* - * coswitch(old_cs, new_cs, first) for DEC Alpha architecture - * $16 $17 $18 - */ - .data -errmsg: .ascii "new_context() returned in coswitch\X00" - - .text - .globl coswitch - .ent coswitch -coswitch: - lda $sp, -72($sp) /* make room on stack */ - stq $sp, 0($16) /* save stack pointer */ - stq $9, 0($sp) /* save registers on stack */ - stq $10, 8($sp) - stq $11, 16($sp) - stq $12, 24($sp) - stq $13, 32($sp) - stq $14, 40($sp) - stq $15, 48($sp) - stq $27, 56($sp) - stq $26, 64($sp) /* return address */ - beq $18, first /* if first time */ - - ldq $sp, 0($17) /* load new stack pointer */ - ldq $9, 0($sp) /* load registers from stack */ - ldq $10, 8($sp) - ldq $11, 16($sp) - ldq $12, 24($sp) - ldq $13, 32($sp) - ldq $14, 40($sp) - ldq $15, 48($sp) - ldq $27, 56($sp) - ldq $26, 64($sp) /* return address */ - lda $sp, 72($sp) /* reset sp */ - jsr_coroutine $31, ($26), 0 /* jump into new_context */ - -first: - ldq $sp, 0($17) /* load stack pointer only */ - bis $31, $31, $16 /* r16 = 0 */ - bis $31, $31, $17 /* r17 = 0 */ - jsr $26, new_context /* new_context(0,0) */ - lda $16, errmsg - jsr $26, syserr /* shouldn't get here */ - - .end coswitch diff --git a/config/bsd/define.h b/config/bsd/define.h index 1859df0..e1adb04 100644 --- a/config/bsd/define.h +++ b/config/bsd/define.h @@ -4,7 +4,3 @@ #define UNIX 1 #define LoadFunc - -#define CComp "gcc" -#define COpts "-O -I/usr/X11R6/include" -#define ICONC_XLIB "-Wl,-R/usr/X11R6/lib -L/usr/X11R6/lib -lX11" diff --git a/config/bsd/i386.c b/config/bsd/i386.c deleted file mode 100644 index 1eecd7c..0000000 --- a/config/bsd/i386.c +++ /dev/null @@ -1,23 +0,0 @@ -/* - * coswitch for the i386 architecture - */ - -int -coswitch (int *old_cs, int *new_cs, int first) -{ - asm ("movl 8(%ebp),%eax"); - asm ("movl %esp,0(%eax)"); - asm ("movl %ebp,4(%eax)"); - asm ("movl 12(%ebp),%eax"); - - if (first == 0) { /* this is the first activation */ - asm ("movl 0(%eax),%esp"); - asm ("movl $0,%ebp"); - new_context (0, 0); - syserr ("new_context() returned in coswitch"); - } - else { - asm ("movl 0(%eax),%esp"); - asm ("movl 4(%eax),%ebp"); - } -} diff --git a/config/bsd/m68k.c b/config/bsd/m68k.c deleted file mode 100644 index 077922b..0000000 --- a/config/bsd/m68k.c +++ /dev/null @@ -1,25 +0,0 @@ -/* - * coswitch for the m68k architecture - */ - -int -coswitch (int *old_cs, int *new_cs, int first) -{ - asm ("movl %a6@(8),%a0"); /* a0 = old */ - asm ("movl %a6@(12),%a1"); /* a1 = new */ - asm ("movl %a7,%a0@"); /* save sp in cstate[0] */ - asm ("movl %a6,%a0@(4)"); /* save a6 (fp) in cstate[0] */ - asm ("moveml #0x3cfc,%a0@(8)"); /* store d2-d7, a2-a6 in old->cstate */ - - if (first == 0) { /* this is first activation */ - asm ("movl %a1@,%a7"); - asm ("movl #0,%a6"); - new_context (0, 0); - syserr ("new_context() returned in coswitch"); - } - else { - asm ("movl %a1@,%a7"); /* restore sp */ - asm ("movl %a1@(4),%a6"); /* restore fp */ - asm ("moveml %a1@(8),#0x3cfc"); /* restore d2-d7, a2-a6 */ - } -} diff --git a/config/bsd/powerpc.s b/config/bsd/powerpc.s deleted file mode 100644 index 8044959..0000000 --- a/config/bsd/powerpc.s +++ /dev/null @@ -1,78 +0,0 @@ -# -# coswitch for the PowerPC architecture -# - - .file "rswitch.s" - - .data -errmsg: .string "new_context() returned in coswitch\n" - - .text - .align 2 - .globl coswitch - .type coswitch,@function - -coswitch: - stwu 1, -80(1) # allocate stack frame - - # Save Old Context: - stw 1, 0(3) # SP - mflr 0 - stw 0, 4(3) # LR (return address) - stw 14, 0(1) # GPRs 14-31 (save on stack) - stw 15, 4(1) - stw 16, 8(1) - stw 17, 12(1) - stw 18, 16(1) - stw 19, 20(1) - stw 20, 24(1) - stw 21, 28(1) - stw 22, 32(1) - stw 23, 36(1) - stw 24, 40(1) - stw 25, 44(1) - stw 26, 48(1) - stw 27, 52(1) - stw 28, 56(1) - stw 29, 60(1) - stw 30, 64(1) - stw 31, 68(1) - - cmpi 0, 5, 0 - beq first # if first time - - # Restore new context: - lwz 1, 0(4) # SP - lwz 0, 4(4) # LR - mtlr 0 - lwz 14, 0(1) # GPRs 14-31 (from stack) - lwz 15, 4(1) - lwz 16, 8(1) - lwz 17, 12(1) - lwz 18, 16(1) - lwz 19, 20(1) - lwz 20, 24(1) - lwz 21, 28(1) - lwz 22, 32(1) - lwz 23, 36(1) - lwz 24, 40(1) - lwz 25, 44(1) - lwz 26, 48(1) - lwz 27, 52(1) - lwz 28, 56(1) - lwz 29, 60(1) - lwz 30, 64(1) - lwz 31, 68(1) - - addic 1, 1, 80 # deallocate stack frame - blr # return into new context - -first: # First-time call: - lwz 1, 0(4) # SP as figured by Icon - addic 1, 1, -64 # save area for callee - addi 3, 0, 0 # arg1 - addi 4, 0, 0 # arg2 - bl new_context # new_context(0,0) - lis 3, errmsg@ha - la 3, errmsg@l(3) - bl syserr diff --git a/config/bsd/sparc.c b/config/bsd/sparc.c deleted file mode 100644 index 4f2215c..0000000 --- a/config/bsd/sparc.c +++ /dev/null @@ -1,33 +0,0 @@ -/* - * coswitch for the SPARC architecture - */ - -int -coswitch (int *old_cs, int *new_cs, int first) -{ - asm("ta 0x03"); /* ST_FLUSH_WINDOWS in trap.h */ - asm("ld [%fp+0x44], %o0"); /* load old_cs into %o0 */ - asm("st %sp,[%o0]"); /* Save user stack pointer */ - asm("st %fp,[%o0+0x4]"); /* Save frame pointer */ - asm("st %i7,[%o0+0x8]"); /* Save return address */ - - if (first == 0) { /* this is the first activation */ - asm("ld [%fp+0x48], %o0"); /* load new_cs into %o0 */ - asm("ld [%o0], %o1"); /* load %o1 from cstate[0] */ - - /* Decrement new stack pointer value before loading it into sp. */ - /* The top 64 bytes of the stack are reserved for the kernel, to */ - /* save the 8 local and 8 in registers into, on context switches, */ - /* interrupts, traps, etc. */ - - asm("save %o1,-96, %sp"); /* load %sp from %o1 */ - new_context(0,0); - syserr("new_context() returned in coswitch"); - - } else { - asm("ld [%fp+0x48], %o0"); /* load new_cs into %o0 */ - asm("ld [%o0+0x4],%fp"); /* Load frame pointer */ - asm("ld [%o0+0x8],%i7"); /* Load return address */ - asm("ld [%o0],%sp"); /* Load user stack pointer */ - } -} diff --git a/config/bsd/status b/config/bsd/status index e0fba53..4179d1f 100644 --- a/config/bsd/status +++ b/config/bsd/status @@ -4,7 +4,7 @@ System configuration: Latest Icon version: - Version 9.4.3 + Version 9.5.0 Installer: @@ -25,10 +25,8 @@ Comments: This configuration is for FreeBSD, NetBSD, and OpenBSD. For Darwin (Apple Macintosh), use the "macintosh" configuration. - This configuration can use pthreads for context switching. - - Tested on FreeBSD 6.0-beta5 (i386 and amd64). + Tested on OpenBSD 4.6. Date: - November 10, 2005 + March 26, 2010 diff --git a/config/bsd/vax.c b/config/bsd/vax.c deleted file mode 100644 index 52d30f9..0000000 --- a/config/bsd/vax.c +++ /dev/null @@ -1,38 +0,0 @@ -/* - * coswitch for the VAX architecture - */ - -int -coswitch (int *old_cs, int *new_cs, int first) -{ - asm ("movl 4(%ap),%r0"); - asm ("movl 8(%ap),%r1"); - asm ("movl %sp,0(%r0)"); - asm ("movl %fp,4(%r0)"); - asm ("movl %ap,8(%r0)"); - asm ("movl %r11,16(%r0)"); - asm ("movl %r10,20(%r0)"); - asm ("movl %r9,24(%r0)"); - asm ("movl %r8,28(%r0)"); - asm ("movl %r7,32(%r0)"); - asm ("movl %r6,36(%r0)"); - - if (first == 0) { /* this is the first activation */ - asm ("movl 0(%r1),%sp"); - asm ("clrl %fp"); - asm ("clrl %ap"); - new_context (0,0); - syserr ("new_context() returned in coswitch"); - } - else { - asm ("movl 0(%r1),%sp"); - asm ("movl 4(%r1),%fp"); - asm ("movl 8(%r1),%ap"); - asm ("movl 16(%r1),%r11"); - asm ("movl 20(%r1),%r10"); - asm ("movl 24(%r1),%r9"); - asm ("movl 28(%r1),%r8"); - asm ("movl 32(%r1),%r7"); - asm ("movl 36(%r1),%r6"); - } -} diff --git a/config/cygwin/Makedefs b/config/cygwin/Makedefs index 2ddf6fb..ce7103b 100644 --- a/config/cygwin/Makedefs +++ b/config/cygwin/Makedefs @@ -10,8 +10,9 @@ CC = gcc CFLAGS = -O -CFDYN = -fpic -RLINK = -Wl,-E +CFDYN = +# make win32 import library for callbacks +RLINK = -Wl,--export-all-symbols -Wl,--out-implib=iconx.a RLIBS = -lm TLIBS = XLIBS = -luser32 -lgdi32 -lcomdlg32 -lwinmm diff --git a/config/cygwin/define.h b/config/cygwin/define.h index d2925a0..b9d823d 100644 --- a/config/cygwin/define.h +++ b/config/cygwin/define.h @@ -1,5 +1,5 @@ /* - * Icon configuration file for Cygwin environment on Microsoft Windows + * Icon configuration file for Cygwin using Windows API for graphics */ #define MSWIN 1 /* this configuration is for Microsoft Windows */ #define CYGWIN 1 /* this configuration uses Cygwin API */ @@ -7,10 +7,10 @@ #define FAttrib /* enable fattrib() extension */ #define WinExtns /* enable native Windows functions */ -#define CComp "gcc" +#define LoadFunc 1 /* enable dynamic loading */ #define ExecSuffix ".exe" #define IcodeSuffix ".exe" #define BinaryHeader -#define MaxHdr 16384 +#define MaxHdr 16384 diff --git a/config/cygwin/status b/config/cygwin/status index ad06c71..be9ca79 100644 --- a/config/cygwin/status +++ b/config/cygwin/status @@ -1,39 +1,33 @@ System configuration: - The Cygwin Unix environment running on Microsoft Windows NT + Cygwin on Windows XP using the Windows graphics API Latest Icon version: - Version 9.4.3 + Version 9.5.0 Installer: - Gregg Townsend - Icon Project - The University of Arizona - (with thanks to Frank J. Lhota) + Carl Sturtivant + University of Minnesota Missing features: - Dynamic loading (loadfunc) + None Known bugs: - Some tests (typically io, tpp, and opts) fail due to Unix - dependencies. + The "options" test fails due to Unix dependencies. - There are many rough edges in the graphics area, which has - not been well tested. + There are still some rough edges in the graphics area. Comments: See the special Cygwin page in the documentation directory. - This configuration now uses POSIX threads for context switching; - the former "rswitch.c" code failed in the latest test environment. - - Tested with GCC 3.4.4 on Cygwin 1.5.18. + This version includes MS Windows extensions retained for + backward compatibility. Date: - November 4, 2005 + June 4, 2008 diff --git a/config/hpux/define.h b/config/hpux/define.h index d6fa049..d99c258 100644 --- a/config/hpux/define.h +++ b/config/hpux/define.h @@ -3,5 +3,4 @@ */ #define UNIX 1 -#define CStateSize 20 #define StackSize 10000 diff --git a/config/hurd/define.h b/config/hurd/define.h index 5bbb3e0..1a81c6c 100644 --- a/config/hurd/define.h +++ b/config/hurd/define.h @@ -4,6 +4,3 @@ #define UNIX 1 #define LoadFunc - -#define CComp "gcc" -#define COpts "-O -fomit-frame-pointer" diff --git a/config/hurd/rswitch.c b/config/hurd/rswitch.c deleted file mode 100644 index 4a9def0..0000000 --- a/config/hurd/rswitch.c +++ /dev/null @@ -1,27 +0,0 @@ -/* - * This is the co-expression context switch for the GNU system. - */ - -/* - * coswitch - */ - -coswitch(old_cs, new_cs, first) -int *old_cs, *new_cs; -int first; - { - asm(" movl 8(%ebp),%eax"); - asm(" movl %esp,0(%eax)"); - asm(" movl %ebp,4(%eax)"); - asm(" movl 12(%ebp),%eax"); - if (first == 0) { /* this is the first activation */ - asm(" movl 0(%eax),%esp"); - asm(" movl $0,%ebp"); - new_context(0, 0); - syserr("interp() returned in coswitch"); - } - else { - asm(" movl 0(%eax),%esp"); - asm(" movl 4(%eax),%ebp"); - } - } diff --git a/config/irix/define.h b/config/irix/define.h index 9704a1f..68ad567 100644 --- a/config/irix/define.h +++ b/config/irix/define.h @@ -5,9 +5,4 @@ #define UNIX 1 #define LoadFunc -#define CStateSize 32 /* anything >= 26 should actually do */ - -#define CComp "c89" -#define COpts "-Wf,-XNd10000" - #define GammaCorrection 1.0 /* for old X11R5 systems */ diff --git a/config/irix/rswitch.s b/config/irix/rswitch.s deleted file mode 100644 index e820e3d..0000000 --- a/config/irix/rswitch.s +++ /dev/null @@ -1,76 +0,0 @@ - .data - .align 0 -$$8: - .ascii "new_context() returned in coswitch\X00" - .text - .align 2 - .globl coswitch - # coswitch(old_cs,new_cs,first) - # int *old_cs,*new_cs; - # int first; - # { - .ent coswitch -coswitch: - # standard entry code, including decrement of sp - subu $sp, 32 - sw $31, 20($sp) - .mask 0x80000000, -4 - .frame $sp, 32, $31 - # save (decremented) sp and other registers in old_cs - sw $sp, 0($4) - sw $31, 4($4) - sd $16, 8($4) - sd $18, 16($4) - sd $20, 24($4) - sd $22, 32($4) - s.d $f20,40($4) - s.d $f22,48($4) - s.d $f24,56($4) - s.d $f26,64($4) - s.d $f28,72($4) - s.d $f30,80($4) - sw $gp,88($4) - sw $fp,96($4) - # if first = 0, this is first activation - bne $6, 0, $33 - # load sp from new_cs[0] (ignore other registers) - lw $sp, 0($5) - # Decrement sp by the size of the stackframe. - # Store decremented sp in new_cs. Then call new_context(). - subu $sp, 32 - sw $sp, 0($5) - # new_context(0,0); - move $4, $0 - move $5, $0 - jal new_context - # syserr("new_context() returned in coswitch"); - la $4, $$8 - jal syserr - # if we're in control now, something is really wrong, so go into - # a tight loop until someone notices... -$32: - b $32 -$33: - # here for not first activation - # load sp and other registers from new_cs - lw $sp, 0($5) - lw $31, 4($5) - # (could compare $31 with 20($sp) as a consistency check now) - ld $16, 8($5) - ld $18, 16($5) - ld $20, 24($5) - ld $22, 32($5) - l.d $f20,40($5) - l.d $f22,48($5) - l.d $f24,56($5) - l.d $f26,64($5) - l.d $f28,72($5) - l.d $f30,80($5) - lw $gp,88($5) - lw $fp,96($5) - # increment sp as for normal return - addu $sp, 32 - # return - j $31 - # } - .end coswitch diff --git a/config/irix/status b/config/irix/status index 58fc639..70b0948 100644 --- a/config/irix/status +++ b/config/irix/status @@ -24,8 +24,6 @@ Comments: Tested on Silicon Graphics Indigo2 IMPACT running IRIX 6.5.7f. - This configuration can use pthreads for context switching. - Date: March 26, 2003 diff --git a/config/linux/Makedefs b/config/linux/Makedefs index da053aa..613b74d 100644 --- a/config/linux/Makedefs +++ b/config/linux/Makedefs @@ -14,6 +14,6 @@ CFDYN = -fPIC RLINK = -Wl,-E RLIBS = -lm -ldl TLIBS = -lpthread -XLIBS = -L/usr/X11R6/lib64 -L/usr/X11R6/lib -lX11 +XLIBS = -lX11 XPMDEFS = -DZPIPE GDIR = xpm diff --git a/config/linux/alpha.s b/config/linux/alpha.s deleted file mode 100644 index a4589d4..0000000 --- a/config/linux/alpha.s +++ /dev/null @@ -1,46 +0,0 @@ -/* - * coswitch(old_cs, new_cs, first) for Dec Alpha architecture - * $16 $17 $18 - */ - .data -errmsg: .ascii "new_context() returned in coswitch\X00" - - .text - .globl coswitch - .ent coswitch -coswitch: - lda $sp, -72($sp) /* make room on stack */ - stq $sp, 0($16) /* save stack pointer */ - stq $9, 0($sp) /* save registers on stack */ - stq $10, 8($sp) - stq $11, 16($sp) - stq $12, 24($sp) - stq $13, 32($sp) - stq $14, 40($sp) - stq $15, 48($sp) - stq $27, 56($sp) - stq $26, 64($sp) /* return address */ - beq $18, first /* if first time */ - - ldq $sp, 0($17) /* load new stack pointer */ - ldq $9, 0($sp) /* load registers from stack */ - ldq $10, 8($sp) - ldq $11, 16($sp) - ldq $12, 24($sp) - ldq $13, 32($sp) - ldq $14, 40($sp) - ldq $15, 48($sp) - ldq $27, 56($sp) - ldq $26, 64($sp) /* return address */ - lda $sp, 72($sp) /* reset sp */ - jsr_coroutine $31, ($26), 0 /* jump into new_context */ - -first: - ldq $sp, 0($17) /* load stack pointer only */ - bis $31, $31, $16 /* r16 = 0 */ - bis $31, $31, $17 /* r17 = 0 */ - jsr $26, new_context /* new_context(0,0) */ - lda $16, errmsg - jsr $26, syserr /* shouldn't get here */ - - .end coswitch diff --git a/config/linux/define.h b/config/linux/define.h index 834bb2b..982d3c5 100644 --- a/config/linux/define.h +++ b/config/linux/define.h @@ -4,6 +4,3 @@ #define UNIX 1 #define LoadFunc - -#define CComp "gcc" -#define COpts "-O -fomit-frame-pointer" diff --git a/config/linux/i686.s b/config/linux/i686.s deleted file mode 100644 index 2e7117e..0000000 --- a/config/linux/i686.s +++ /dev/null @@ -1,44 +0,0 @@ -# -# Assembler source for context switch using gas 1.38.1 + gcc 1.40 on -# Xenix/386, revamped slightly for use with Linux by me (Richard Goer- -# witz) on 7/25/94. -# - -.file "rswitch.s" -.data 1 -.LC0: - .byte 0x6e,0x65,0x77,0x5f,0x63,0x6f,0x6e,0x74,0x65,0x78 - .byte 0x74,0x28,0x29,0x20,0x72,0x65,0x74,0x75,0x72,0x6e - .byte 0x65,0x64,0x20,0x69,0x6e,0x20,0x63,0x6f,0x73,0x77 - .byte 0x69,0x74,0x63,0x68,0x0 -.text - .align 4 -.globl coswitch - - -coswitch: - pushl %ebp - movl %esp,%ebp - movl 8(%ebp),%eax - movl %esp,0(%eax) - movl %ebp,4(%eax) - movl 12(%ebp),%eax - cmpl $0,16(%ebp) - movl 0(%eax),%esp - je .L2 - - movl 4(%eax),%ebp - jmp .L1 - -.L2: - movl $0,%ebp - pushl $0 - pushl $0 - call new_context - pushl $.LC0 - call syserr - addl $12,%esp - -.L1: - leave - ret diff --git a/config/linux/parisc.s b/config/linux/parisc.s deleted file mode 100644 index 88d9366..0000000 --- a/config/linux/parisc.s +++ /dev/null @@ -1,68 +0,0 @@ -; coexpression code for HP PA-RISC architecture for Icon 8.10 -; -; n.b. two of the three coexpression tests work, but coexpression -; *transmission*, a rarely used feature, does not - - .CODE - .IMPORT syserr - .EXPORT coswitch -coswitch - .PROC - .CALLINFO - .ENTRY - ; store old registers - STW %sp,0(%arg0) - ; not used: 4(%arg0) - STW %rp,8(%arg0) - STW %r3,12(%arg0) - STW %r4,16(%arg0) - STW %r5,20(%arg0) - STW %r6,24(%arg0) - STW %r7,28(%arg0) - STW %r8,32(%arg0) - STW %r9,36(%arg0) - STW %r10,40(%arg0) - STW %r11,44(%arg0) - STW %r12,48(%arg0) - STW %r13,52(%arg0) - STW %r14,56(%arg0) - STW %r15,60(%arg0) - STW %r16,64(%arg0) - STW %r17,68(%arg0) - STW %r18,72(%arg0) - - COMIB,=,N 0,%arg2,L$isfirst - - ; this is not a first-time call; reload old context - LDW 0(%arg1),%sp - LDW 8(%arg1),%rp - LDW 12(%arg1),%r3 - LDW 16(%arg1),%r4 - LDW 20(%arg1),%r5 - LDW 24(%arg1),%r6 - LDW 28(%arg1),%r7 - LDW 32(%arg1),%r8 - LDW 36(%arg1),%r9 - LDW 40(%arg1),%r10 - LDW 44(%arg1),%r11 - LDW 48(%arg1),%r12 - LDW 52(%arg1),%r13 - LDW 56(%arg1),%r14 - LDW 60(%arg1),%r15 - LDW 64(%arg1),%r16 - LDW 68(%arg1),%r17 - LDW 72(%arg1),%r18 - BV,N (%rp) ; return - -L$isfirst - LDW 0(%arg1),%sp - LDI 0,%arg0 - LDI 0,%arg1 - .CALL ARGW0=GR,ARGW1=GR - BL,N new_context,%rp ; call new_context(0,0) - SUBI 1,%r0,%rp - BV,N (%rp) ; abort w/ illegal jump - .EXIT - .PROCEND - .IMPORT new_context,CODE - .END diff --git a/config/linux/sparc.c b/config/linux/sparc.c deleted file mode 100644 index 743bb02..0000000 --- a/config/linux/sparc.c +++ /dev/null @@ -1,36 +0,0 @@ -/* - * coswitch for Sun-4 Sparc. - * - * Compile this with 'gcc -c rswitch.c'. Do not use gcc -O. - */ - -int coswitch(old_cs, new_cs, first) -int *old_cs, *new_cs; -int first; -{ - asm("ta 0x03"); /* ST_FLUSH_WINDOWS in trap.h */ - asm("ld [%fp+0x44], %o0"); /* load old_cs into %o0 */ - asm("st %sp,[%o0]"); /* Save user stack pointer */ - asm("st %fp,[%o0+0x4]"); /* Save frame pointer */ - asm("st %i7,[%o0+0x8]"); /* Save return address */ - - if (first == 0) { /* this is the first activation */ - asm("ld [%fp+0x48], %o0"); /* load new_cs into %o0 */ - asm("ld [%o0], %o1"); /* load %o1 from cstate[0] */ - - /* Decrement new stack pointer value before loading it into sp. */ - /* The top 64 bytes of the stack are reserved for the kernel, to */ - /* save the 8 local and 8 in registers into, on context switches, */ - /* interrupts, traps, etc. */ - - asm("save %o1,-96, %sp"); /* load %sp from %o1 */ - new_context(0,0); - syserr("new_context() returned in coswitch"); - - } else { - asm("ld [%fp+0x48], %o0"); /* load new_cs into %o0 */ - asm("ld [%o0+0x4],%fp"); /* Load frame pointer */ - asm("ld [%o0+0x8],%i7"); /* Load return address */ - asm("ld [%o0],%sp"); /* Load user stack pointer */ - } -} diff --git a/config/linux/status b/config/linux/status index 499c0fa..497be73 100644 --- a/config/linux/status +++ b/config/linux/status @@ -4,7 +4,7 @@ System configuration: Latest Icon version: - Version 9.4.3 + Version 9.5.0 Installer: @@ -12,30 +12,22 @@ Installer: Icon Project The University of Arizona - with special thanks to Christian Hudon for additional testing - Missing features: None Known bugs: - None on x86, amd64, Alpha, SPARC, ARM, s390, or m68k. - - On PowerPC: Large integers don't work; the cause is unknown. - - On HP PA-RISC architecture: Icon is not functional. For - reasons that are not understood, real (floating-point) - values do not work. + None Comments: - Tested on x86 and amd64 architectures under Red Hat 9, - Fedora 3, and Fedora 4. + Tested on various x86 and x64 systems running Fedora 9, + Ubuntu 9.04 and 9.10, and Debian Squeeze. - This configuration can use pthreads for context switching. - On some architectures that is the only option. + Ubuntu may require package installation in order to build: + $ sudo apt-get install build-essential libx11-dev libxt-dev libxaw7-dev Date: - November 8, 2005 + April 5, 2010 diff --git a/config/mac386/Makedefs b/config/mac386/Makedefs new file mode 100644 index 0000000..35f3984 --- /dev/null +++ b/config/mac386/Makedefs @@ -0,0 +1,21 @@ +# CC C compiler +# CFLAGS flags for building C files +# CFDYN additional flags for dynamic functions +# RLINK flags for linking run-time system +# RLIBS libraries to link with run-time system +# TLIBS libraries to link for POSIX threads +# XLIBS libraries to link for graphics +# XPMDEFS definitions for building XPM library +# GDIR directory of graphics helper library +# SFLAGS flags for stripping iconx + +CC = cc -arch i386 +CFLAGS = +CFDYN = +RLINK = -dynamic +RLIBS = -lm +TLIBS = +XLIBS = -L/usr/X11/lib -lX11 +XPMDEFS = -DZPIPE +GDIR = xpm +SFLAGS = -Sx diff --git a/config/mac386/define.h b/config/mac386/define.h new file mode 100644 index 0000000..bf2a07e --- /dev/null +++ b/config/mac386/define.h @@ -0,0 +1,9 @@ +/* + * Icon configuration file for Macintosh + */ + +#define UNIX 1 +#define MACINTOSH 1 +#define LoadFunc + +#define NamedSemaphores /* unnamed sempahores not implemented by OS 10.6 */ diff --git a/config/mac386/status b/config/mac386/status new file mode 100644 index 0000000..3d1cfef --- /dev/null +++ b/config/mac386/status @@ -0,0 +1,34 @@ +System configuration: + + 32-bit variant configuration for Intel-based Apple Macintosh. + +Latest Icon version: + + Version 9.5.0 + +Installer: + + Gregg Townsend + Icon Project + The University of Arizona + +Missing features: + + None + +Known bugs: + + None + +Comments: + + This configuration forces a 32-bit build of Icon on a 64-bit + Intel-based Macintosh computer. This is normally not needed and + the standard "macintosh" configuration should be used instead. + + Tested with MacOS 10.6.2 (Snow Leopard), + using Xcode 3.2.1 and GCC 4.2.1. + +Date: + + March 26, 2010 diff --git a/config/macintosh/Makedefs b/config/macintosh/Makedefs index 381b077..c8af32b 100644 --- a/config/macintosh/Makedefs +++ b/config/macintosh/Makedefs @@ -10,12 +10,12 @@ # SFLAGS flags for stripping iconx CC = cc -CFLAGS = -I/usr/X11R6/include +CFLAGS = CFDYN = RLINK = -dynamic RLIBS = -lm TLIBS = -XLIBS = -L/usr/X11R6/lib -lX11 -XPMDEFS = -DZPIPE -I/usr/X11R6/include +XLIBS = -L/usr/X11/lib -lX11 +XPMDEFS = -DZPIPE GDIR = xpm SFLAGS = -Sx diff --git a/config/macintosh/define.h b/config/macintosh/define.h index e1857dd..bf2a07e 100644 --- a/config/macintosh/define.h +++ b/config/macintosh/define.h @@ -3,6 +3,7 @@ */ #define UNIX 1 +#define MACINTOSH 1 #define LoadFunc -#define NamedSemaphores /* unnamed sempahores not implemented by OS 10.4 */ +#define NamedSemaphores /* unnamed sempahores not implemented by OS 10.6 */ diff --git a/config/macintosh/powerpc.s b/config/macintosh/powerpc.s deleted file mode 100644 index 71724a6..0000000 --- a/config/macintosh/powerpc.s +++ /dev/null @@ -1,52 +0,0 @@ -# coswitch(old, new, first) -# GPR3 GPR4 GPR5 - -# This code is modeled after the ppc_aix context switch -# it was compared to the Darwin context switch routine to -# get the syntax correct for the Apple gcc compiler. -.macro ENTRY - .text - .align 2 - .globl $0 -$0: -.endmacro - - .file "rswitch.s" - .set RSIZE, 80 ; room for regs 13-31, rounded up mod16 - - ENTRY _coswitch - - stwu r1, -RSIZE(r1) ; allocate stack frame - - ; Save Old Context: - stw r1, 0(r3) ; SP - stw r2, 4(r3) ; TOC - mflr r0 - stw r0, 8(r3) ; LR (return address) - mfcr r0 - stw r0, 12(r3) ; CR - stmw r13, -RSIZE(r1) ; GPRs 13-31 (save on stack) - - cmpi 0, r5, 0 - beq first ; if first time - - ; Restore new context: - lwz r1, 0(r4) ; SP - lwz r2, 4(r4) ; TOC - lwz r0, 8(r4) ; LR - mtlr r0 - lwz r0, 12(r4) ; CR - mtcr r0 - lmw r13, -RSIZE(r1) ; GPRs 13-31 (from stack) - - addic r1, r1, RSIZE ; deallocate stack frame - blr ; return into new context - -first: ; First-time call: - lwz r1, 0(r4) ; SP as figured by Icon - addic r1, r1, -64 ; save area for callee - addi r3, 0, 0 ; arg1 - addi r4, 0, 0 ; arg2 - bl _new_context ; new_context(0,0) - addi r3, 0, 0 - bl _syserr diff --git a/config/macintosh/status b/config/macintosh/status index 43dffac..a49aecc 100644 --- a/config/macintosh/status +++ b/config/macintosh/status @@ -1,10 +1,10 @@ System configuration: - Apple Macintosh running OS X (10.1 or newer) + Apple Macintosh running MacOS X Latest Icon version: - Version 9.4.3 + Version 9.5.0 Installer: @@ -26,18 +26,11 @@ Comments: Icon runs on Darwin, which is (loosely speaking) the command-line-based Unix substructure of MacOS X. The - Xcode Developer Tools must be installed. (These come - with MacOS on a CD that is not always installed.) + Xcode Developer Tools must be installed to build Icon. - An Icon installation with graphics requires the X11 window - system, available from Apple but not always installed. - To install Icon without graphics, use "make Configure" - instead of "make X-Configure" when building. - - This configuration can use pthreads for context switching. - - Tested with MacOS 10.4.3 (Tiger). + Tested with MacOS 10.6.3 (Snow Leopard), + using Xcode 3.2.1 and GCC 4.2.1. Date: - November 10, 2005 + March 29, 2010 diff --git a/config/posix/Makedefs b/config/posix/Makedefs index 9959341..391a154 100644 --- a/config/posix/Makedefs +++ b/config/posix/Makedefs @@ -9,11 +9,11 @@ # GDIR directory of graphics helper library CC = cc -CFLAGS = -O -I/usr/X11R6/include +CFLAGS = -O CFDYN = RLINK = RLIBS = -lm TLIBS = -lpthread -XLIBS = -L/usr/X11R6/lib -lX11 -XPMDEFS = -DZPIPE -I/usr/X11R6/include +XLIBS = -L/usr/X11/lib -lX11 +XPMDEFS = -DZPIPE GDIR = xpm diff --git a/config/posix/define.h b/config/posix/define.h index e2d54c5..7f22c1d 100644 --- a/config/posix/define.h +++ b/config/posix/define.h @@ -3,5 +3,5 @@ */ #define UNIX 1 -/* LoadFunc not implemented */ +#define LoadFunc diff --git a/config/posix/status b/config/posix/status index 66ee6b3..756fb94 100644 --- a/config/posix/status +++ b/config/posix/status @@ -4,7 +4,7 @@ System configuration: Latest Icon version: - Version 9.4.3 + Version 9.5.0 Installer: @@ -14,11 +14,12 @@ Installer: Missing features: - Dynamic loading (loadfunc) + None Known bugs: May need some tweaking of Makedefs for any particular system. + The file ipl/cfuncs/mklib.sh will probably also need editing. Comments: @@ -26,4 +27,4 @@ Comments: Date: - November 8, 2005 + October 28, 2009 diff --git a/config/setup.sh b/config/setup.sh index 90c735d..e015b87 100755 --- a/config/setup.sh +++ b/config/setup.sh @@ -2,11 +2,10 @@ # # setup.sh -- invoked by top-level Makefile -USAGE="usage: setup.sh configname [No]Graphics [pthreads]" +USAGE="usage: setup.sh configname [No]Graphics" NAME=$1 GPX=$2 -CSW=$3 TOP=.. SRC=$TOP/src @@ -16,11 +15,6 @@ case "$GPX" in NoGraphics) XL= ;; *) echo "$USAGE" 1>&2; exit 1;; esac -case "$CSW" in - custom | "") ;; - pthreads) ;; - *) echo "$USAGE" 1>&2; exit 1;; -esac # check that configuration exists if [ ! -d "$NAME" ]; then @@ -28,47 +22,9 @@ if [ ! -d "$NAME" ]; then exit 1 fi -# find and copy the context switch code. -# use pthreads version if specified, or as a last resort. -# first try `uname -p`.[cs] or `uname -m`.[cs] and then rswitch.[cs]. -ARCH=`uname -p 2>/dev/null || echo unknown` -if [ "$ARCH" = "unknown" ]; then - ARCH=`uname -m` -fi -if [ "$CSW" = "pthreads" ]; then - RSW=pthreads.c - COCLEAN="#define CoClean" -elif [ -f "$NAME/$ARCH.c" ]; then - RSW="$NAME/$ARCH.c" - COCLEAN= -elif [ -f "$NAME/$ARCH.s" ]; then - RSW="$NAME/$ARCH.s" - COCLEAN= -elif [ -f $NAME/rswitch.[cs] ]; then - RSW=`echo $NAME/rswitch.[cs]` - COCLEAN= -else - RSW=pthreads.c - COCLEAN="#define CoClean" -fi -case $RSW in - *.c) DRSW=rswitch.c;; - *.s) DRSW=rswitch.s;; -esac -cp $RSW $SRC/common/$DRSW - -if [ "$RSW" = "pthreads.c" ]; then - TL='$(TLIBS)' -else - TL= -fi - -RSN=`echo $RSW | sed 's=.*/=='` - # build the "define.h" file -echo "#define Config \"$NAME, $RSN\"" > $SRC/h/define.h +echo "#define Config \"$NAME\"" > $SRC/h/define.h echo "#define $GPX 1" >> $SRC/h/define.h -echo "$COCLEAN" >> $SRC/h/define.h echo "" >> $SRC/h/define.h cat $NAME/define.h >> $SRC/h/define.h @@ -77,16 +33,12 @@ echo "# from config/$NAME" > $TOP/Makedefs echo "" >> $TOP/Makedefs cat $NAME/Makedefs >> $TOP/Makedefs echo "" >> $TOP/Makedefs -echo "RSW = $DRSW" >> $TOP/Makedefs -echo "TL = $TL" >> $TOP/Makedefs -echo "" >> $TOP/Makedefs echo "# $GPX" >> $TOP/Makedefs echo "XL = $XL" >> $TOP/Makedefs # report actions echo " configured $NAME" echo " with $GPX" -echo " using $RSW" # run customization script, if one exists if [ -f $NAME/custom.sh ]; then diff --git a/config/solaris/Makedefs b/config/solaris/Makedefs index 3f6bd24..7fa50b7 100644 --- a/config/solaris/Makedefs +++ b/config/solaris/Makedefs @@ -9,11 +9,11 @@ # GDIR directory of graphics helper library CC = gcc -CFLAGS = -I/usr/openwin/include +CFLAGS = CFDYN = -fPIC RLINK = RLIBS = -lm -ldl TLIBS = -lposix4 -lpthread -XLIBS = -L /usr/openwin/lib -Xlinker -R/usr/openwin/lib -lX11 +XLIBS = -Xlinker -lX11 XPMDEFS = -DZPIPE -DSYSV GDIR = xpm diff --git a/config/solaris/define.h b/config/solaris/define.h index 12b5119..9a19b3d 100644 --- a/config/solaris/define.h +++ b/config/solaris/define.h @@ -4,7 +4,3 @@ #define UNIX 1 #define LoadFunc - -/* use gcc to compile generated code */ -#define CComp "gcc" -#define COpts "-I/usr/openwin/include -ldl" diff --git a/config/solaris/i386.c b/config/solaris/i386.c deleted file mode 100644 index fa88c93..0000000 --- a/config/solaris/i386.c +++ /dev/null @@ -1,71 +0,0 @@ -/* - * Coswitch for Windows using Visual C++. - * - * Written by Frank J. Lhota, based on an assembly version - * authored by Robert Goldberg and modified for OS/2 2.0 by Mark - * Emmer. - */ - -#include <sys/asm_linkage.h> -#include <sys/trap.h> - -/* - * The Windows co-expression context consists of 5 words. The - * following constants define the byte offsets for each of the - * registers stored in the context. - */ - -#define SP_OFF "0" -#define BP_OFF "4" -#define SI_OFF "8" -#define DI_OFF "12" -#define BX_OFF "16" - -int coswitch(old, new, first) -int *old; -int *new; -int first; -{ - - /* Save current context to *old */ - __asm__ __volatile__ ( - "movl %%esp," SP_OFF "(%0)\n\t" - "movl %%ebp," BP_OFF "(%0)\n\t" - "movl %%esi," SI_OFF "(%0)\n\t" - "movl %%edi," DI_OFF "(%0)\n\t" - "movl %%ebx," BX_OFF "(%0)" - : : "a"( old ) - ); - - if ( first ) - { - /* first != 0 => restore context in *new. */ - __asm__ __volatile__ ( - "movl " SP_OFF "(%0),%%esp\n\t" - "movl " BP_OFF "(%0),%%ebp\n\t" - "movl " SI_OFF "(%0),%%esi\n\t" - "movl " DI_OFF "(%0),%%edi\n\t" - "movl " BX_OFF "(%0),%%ebx" - : : "a"( new ) - ); - } - else - { - /* - * first == 0 => Set things up for first activation of this - * coexpression. Load stack pointer from first - * word of *new and call new_context, which - * should never return. - */ - __asm__ __volatile__ ( - "movl " SP_OFF "(%0),%%esp\n\t" - "movl %%esp,%%ebp" - : : "a"( new ) - ); - new_context( 0, NULL ); - syserr( "interp() returned in coswitch" ); - } - - return 0; -} - diff --git a/config/solaris/sparc.c b/config/solaris/sparc.c deleted file mode 100644 index 6c57a94..0000000 --- a/config/solaris/sparc.c +++ /dev/null @@ -1,39 +0,0 @@ -/* - * coswitch for Sun-4 Sparc. - * - * Compile this with 'gcc -c rswitch.c'. Do not use gcc -O. - */ - -#include <sys/asm_linkage.h> -#include <sys/trap.h> - -int coswitch(old_cs, new_cs, first) -int *old_cs, *new_cs; -int first; -{ - asm("ta 0x03"); /* ST_FLUSH_WINDOWS in trap.h */ - asm("ld [%fp+0x44], %o0"); /* load old_cs into %o0 */ - asm("st %sp,[%o0]"); /* Save user stack pointer */ - asm("st %fp,[%o0+0x4]"); /* Save frame pointer */ - asm("st %i7,[%o0+0x8]"); /* Save return address */ - - if (first == 0) { /* this is the first activation */ - asm("ld [%fp+0x48], %o0"); /* load new_cs into %o0 */ - asm("ld [%o0], %o1"); /* load %o1 from cstate[0] */ - - /* Decrement new stack pointer value before loading it into sp. */ - /* The top 64 bytes of the stack are reserved for the kernel, to */ - /* save the 8 local and 8 in registers into, on context switches, */ - /* interrupts, traps, etc. */ - - asm("save %o1,-96, %sp"); /* load %sp from %o1 */ - new_context(0,0); - syserr("new_context() returned in coswitch"); - - } else { - asm("ld [%fp+0x48], %o0"); /* load new_cs into %o0 */ - asm("ld [%o0+0x4],%fp"); /* Load frame pointer */ - asm("ld [%o0+0x8],%i7"); /* Load return address */ - asm("ld [%o0],%sp"); /* Load user stack pointer */ - } -} diff --git a/config/solaris/status b/config/solaris/status index a2a7a35..b7d0c2a 100644 --- a/config/solaris/status +++ b/config/solaris/status @@ -4,14 +4,13 @@ System configuration: Latest Icon version: - Version 9.4.3 + Version 9.5.0 Installer: Gregg Townsend Icon Project The University of Arizona - (with thanks to Andreas Almroth) Missing features: @@ -23,10 +22,9 @@ Known bugs: Comments: - Tested on SPARC Solaris 2.6 (SunOS 5.6) with gcc version 2.95.3. - Tested on SPARC Solaris 9 (SunOS 5.9) with gcc version 3.4.1. - Tested on x86 Schillix 0.2.1 with gcc version 3.4.3. + Tested on SPARC Solaris 10 (SunOS 5.10) with gcc version 4.2.2, + and on x86 OpenSolaris 2009.6 (5.11) with gcc version 3.4.3. Date: - November 10, 2005 + March 26, 2010 diff --git a/config/solaris_sunc/Makedefs b/config/solaris_sunc/Makedefs index e5bb495..592b2d6 100644 --- a/config/solaris_sunc/Makedefs +++ b/config/solaris_sunc/Makedefs @@ -9,11 +9,11 @@ # GDIR directory of graphics helper library CC = cc -CFLAGS = -O -w -I/usr/openwin/include +CFLAGS = -O -w CFDYN = -KPIC RLINK = RLIBS = -lm -ldl TLIBS = -lposix4 -lpthread -XLIBS = -L /usr/openwin/lib -R/usr/openwin/lib -lX11 +XLIBS = -lX11 XPMDEFS = -DZPIPE -DSYSV GDIR = xpm diff --git a/config/solaris_sunc/define.h b/config/solaris_sunc/define.h index d4789bb..3b89670 100644 --- a/config/solaris_sunc/define.h +++ b/config/solaris_sunc/define.h @@ -4,6 +4,3 @@ #define UNIX 1 #define LoadFunc - -#define CComp "cc" -#define COpts "-I/usr/openwin/include -ldl" diff --git a/config/solaris_sunc/sparc.c b/config/solaris_sunc/sparc.c deleted file mode 100644 index b712211..0000000 --- a/config/solaris_sunc/sparc.c +++ /dev/null @@ -1,37 +0,0 @@ -/* - * coswitch for Sun-4 Sparc. - */ - -#include <sys/asm_linkage.h> -#include <sys/trap.h> - -int coswitch(old_cs, new_cs, first) -int *old_cs, *new_cs; -int first; -{ - asm("ta 0x03"); /* ST_FLUSH_WINDOWS in trap.h */ - asm("ld [%fp+0x44], %o0"); /* load old_cs into %o0 */ - asm("st %sp,[%o0]"); /* Save user stack pointer */ - asm("st %fp,[%o0+0x4]"); /* Save frame pointer */ - asm("st %i7,[%o0+0x8]"); /* Save return address */ - - if (first == 0) { /* this is the first activation */ - asm("ld [%fp+0x48], %o0"); /* load new_cs into %o0 */ - asm("ld [%o0], %o1"); /* load %o1 from cstate[0] */ - - /* Decrement new stack pointer value before loading it into sp. */ - /* The top 64 bytes of the stack are reserved for the kernel, to */ - /* save the 8 local and 8 in registers into, on context switches, */ - /* interrupts, traps, etc. */ - - asm("save %o1,-96, %sp"); /* load %sp from %o1 */ - new_context(0,0); - syserr("new_context() returned in coswitch"); - - } else { - asm("ld [%fp+0x48], %o0"); /* load new_cs into %o0 */ - asm("ld [%o0+0x4],%fp"); /* Load frame pointer */ - asm("ld [%o0+0x8],%i7"); /* Load return address */ - asm("ld [%o0],%sp"); /* Load user stack pointer */ - } -} diff --git a/config/solaris_sunc/status b/config/solaris_sunc/status index 54d26dc..ce854c2 100644 --- a/config/solaris_sunc/status +++ b/config/solaris_sunc/status @@ -4,7 +4,7 @@ System configuration: Latest Icon version: - Version 9.4.3 + Version 9.5.0 Installer: @@ -22,11 +22,8 @@ Known bugs: Comments: - Tested on Sun SPARC systems running Solaris 2.6 (WorkShop C 4.2) - and Solaris 9 (WorkShop C 5.0). - - This configuration can use pthreads for context switching. + Tested on SPARC Solaris 10 (SunOS 5.10) with Sun C 5.9. Date: - November 8, 2005 + March 26, 2010 diff --git a/config/tru64/define.h b/config/tru64/define.h index 78cee03..e06d824 100644 --- a/config/tru64/define.h +++ b/config/tru64/define.h @@ -5,6 +5,3 @@ /* standard Unix and C */ #define UNIX 1 #define LoadFunc - -/* c89 is ANSI C compiler */ -#define CComp "c89" diff --git a/config/tru64/rswitch.s b/config/tru64/rswitch.s deleted file mode 100644 index a4589d4..0000000 --- a/config/tru64/rswitch.s +++ /dev/null @@ -1,46 +0,0 @@ -/* - * coswitch(old_cs, new_cs, first) for Dec Alpha architecture - * $16 $17 $18 - */ - .data -errmsg: .ascii "new_context() returned in coswitch\X00" - - .text - .globl coswitch - .ent coswitch -coswitch: - lda $sp, -72($sp) /* make room on stack */ - stq $sp, 0($16) /* save stack pointer */ - stq $9, 0($sp) /* save registers on stack */ - stq $10, 8($sp) - stq $11, 16($sp) - stq $12, 24($sp) - stq $13, 32($sp) - stq $14, 40($sp) - stq $15, 48($sp) - stq $27, 56($sp) - stq $26, 64($sp) /* return address */ - beq $18, first /* if first time */ - - ldq $sp, 0($17) /* load new stack pointer */ - ldq $9, 0($sp) /* load registers from stack */ - ldq $10, 8($sp) - ldq $11, 16($sp) - ldq $12, 24($sp) - ldq $13, 32($sp) - ldq $14, 40($sp) - ldq $15, 48($sp) - ldq $27, 56($sp) - ldq $26, 64($sp) /* return address */ - lda $sp, 72($sp) /* reset sp */ - jsr_coroutine $31, ($26), 0 /* jump into new_context */ - -first: - ldq $sp, 0($17) /* load stack pointer only */ - bis $31, $31, $16 /* r16 = 0 */ - bis $31, $31, $17 /* r17 = 0 */ - jsr $26, new_context /* new_context(0,0) */ - lda $16, errmsg - jsr $26, syserr /* shouldn't get here */ - - .end coswitch diff --git a/config/tru64/status b/config/tru64/status index 15851f0..b1e9ac1 100644 --- a/config/tru64/status +++ b/config/tru64/status @@ -21,8 +21,6 @@ Comments: Tested on: NekoTech "Jaguar" running Digital Unix 4.0B rev 564 and Compaq AlphaStation 600 running Digital Unix 4.0F rev 1229. - This configuration can use pthreads for context switching. - Date: October 5, 2005 diff --git a/config/xcygwin/Makedefs b/config/xcygwin/Makedefs new file mode 100644 index 0000000..f3df739 --- /dev/null +++ b/config/xcygwin/Makedefs @@ -0,0 +1,23 @@ +# CC C compiler +# CFLAGS flags for building C files +# CFDYN additional flags for dynamic functions +# RLINK flags for linking run-time system +# RLIBS libraries to link with run-time system +# TLIBS libraries to link for POSIX threads +# XLIBS libraries to link for graphics +# XPMDEFS definitions for building XPM library +# GDIR directory of graphics helper library + +CC = gcc +CFLAGS = -O +CFDYN = +# make win32 import library for callbacks +RLINK = -Wl,--export-all-symbols -Wl,--out-implib=iconx.a +RLIBS = -lm +TLIBS = +XLIBS = -L/usr/X11R6/lib -lX11 +XPMDEFS = -DZPIPE +GDIR = xpm + +# EXE extension for executable files +EXE = .exe diff --git a/config/xcygwin/define.h b/config/xcygwin/define.h new file mode 100644 index 0000000..f939ed2 --- /dev/null +++ b/config/xcygwin/define.h @@ -0,0 +1,16 @@ +/* + * Icon configuration file for Cygwin using X Window System graphics + */ +#define MSWIN 1 /* this configuration is for Microsoft Windows */ +#define CYGWIN 1 /* this configuration uses Cygwin API */ +#define XWindows 1 /* this configuration uses X Windows for graphics */ + +#define FAttrib /* enable fattrib() extension */ + +#define LoadFunc 1 /* enable dynamic loading */ + +#define ExecSuffix ".exe" +#define IcodeSuffix ".exe" + +#define BinaryHeader +#define MaxHdr 16384 diff --git a/config/xcygwin/status b/config/xcygwin/status new file mode 100644 index 0000000..55535c2 --- /dev/null +++ b/config/xcygwin/status @@ -0,0 +1,32 @@ +System configuration: + + Cygwin on Windows XP using the X Window System for graphics + +Latest Icon version: + + Version 9.5.0 + +Installer: + + Carl Sturtivant + University of Minnesota + +Missing features: + + None + +Known bugs: + + The "options" test fails due to Unix dependencies. + + Graphics programs can only run within a Cygwin xterm. + +Comments: + + Tested using Cygwin 1.5.25 with GCC 3.4.4 on Windows XP. + + See the special Cygwin page in the documentation directory. + +Date: + + April 3, 2010 diff --git a/doc/build.htm b/doc/build.htm index d494b94..1982cb6 100644 --- a/doc/build.htm +++ b/doc/build.htm @@ -1,7 +1,7 @@ <!doctype html public "-//W3C//DTD HTML 4.01 Transitional//EN"> <HTML> <HEAD> - <TITLE>Building Version 9.4 of Icon from Source</TITLE> + <TITLE>Building Version 9.5 of Icon from Source</TITLE> <LINK REL="STYLESHEET" TYPE="text/css" HREF="istyle.css"> <LINK REL="SHORTCUT ICON" HREF="shortcut.gif"> </HEAD> @@ -10,20 +10,20 @@ <P><A HREF="http://www.cs.arizona.edu/icon/"> <IMG SRC="wwwcube.gif" ALT="[Icon home]" WIDTH=128 HEIGHT=144 BORDER=0 ALIGN=RIGHT> </A> -<H1>Building Version 9.4 of Icon from Source</H1> +<H1>Building Version 9.5 of Icon from Source</H1> <P> Gregg M. Townsend <BR> <SMALL> Department of Computer Science </SMALL> <BR> <SMALL> The University of Arizona </SMALL> -<P> <SMALL> www.cs.arizona.edu/icon/v943/build.htm -<BR> Last updated November 8, 2005 </SMALL> -<!-- $Id: build.htm,v 1.26 2005/11/08 23:24:34 gmt Exp $ --> +<P> <SMALL> www.cs.arizona.edu/icon/v950/build.htm +<BR> Last updated November 8, 2009 </SMALL> +<!-- $Id: build.htm,v 1.27 2009/11/08 21:53:08 gmt Exp $ --> <H2> Introduction </H2> <P> These instructions explain how to build and install the source code of -<A HREF=relnotes.htm>Version 9.4 of Icon</A> under Unix. +<A HREF=relnotes.htm>Version 9.5 of Icon</A> under Unix. For instructions on installing a binary release, see <A HREF=install.htm>Installing Icon Binaries</A>. @@ -48,7 +48,7 @@ any special considerations given in its status report. port the code. This is usually a fairly simple matter that involves copying an existing configuration and editing it to match the target system. -See <A HREF=port.htm>Porting Icon</A>. +See <A HREF=port.htm>Porting Icon</A>.) </SMALL> <P> Most Unix systems include the X11 window system; type @@ -72,7 +72,7 @@ by e-mail to <H2> Building </H2> <P> After Configuring, type <CODE>make</CODE> to build the Icon system. -This single step now builds: +This single step builds: <UL> <LI> The Icon translator and interpreter <LI> Program library procedures diff --git a/doc/cfuncs.htm b/doc/cfuncs.htm new file mode 100644 index 0000000..4243559 --- /dev/null +++ b/doc/cfuncs.htm @@ -0,0 +1,459 @@ +<!doctype html public "-//W3C//DTD HTML 4.01 Transitional//EN"> +<HTML> +<HEAD> + <TITLE>Loading C Functions in Icon</TITLE> + <LINK REL="STYLESHEET" TYPE="text/css" HREF="istyle.css"> + <LINK REL="SHORTCUT ICON" HREF="shortcut.gif"> +</HEAD> +<BODY> + +<P> <A HREF="http://www.cs.arizona.edu/icon/"> <IMG SRC="wwwcube.gif" +ALT="[Icon home]" WIDTH=128 HEIGHT=144 BORDER=0 ALIGN=RIGHT> </A> + + +<H1> Loading C Functions in Icon</H1> + +<P> Gregg M. Townsend +<BR> <SMALL> Department of Computer Science </SMALL> +<BR> <SMALL> The University of Arizona </SMALL> + +<P> <SMALL> www.cs.arizona.edu/icon/v950/cfuncs.htm +<BR> Adapted from +<A HREF="http://www.cs.arizona.edu/icon/analyst/backiss/IA36.pdf"> +<CITE>Icon Analyst 36</CITE></A> +<BR> Last updated October 27, 2009 </SMALL> +<!-- $Id: cfuncs.htm,v 1.3 2009/10/27 17:35:53 gmt Exp $ --> + + +<P> Dynamic loading allows Icon programs to use functions coded in C +without modifying the Icon system itself. The C code is +compiled and placed in a library, then loaded +from the library when the Icon program runs. +Here is a discussion of the use and construction of such functions. + + +<H2> Program library functions </H2> + +<P> The +<A HREF="http://www.cs.arizona.edu/icon/library/ipl.htm">Icon +program library</A> +includes an assortment of loadable Unix +interfaces and special-purpose functions. +Some are there for their general utility, +some for illustration, and some to fill specialized needs. +Here is a sampling: +<BLOCKQUOTE> +<CODE>bitcount(i)</CODE> — count the bits set in an integer +<BR><CODE>chmod(s, i)</CODE> — change the permissions of a file +<BR><CODE>fpoll(f, i)</CODE> — poll a file for input, with timeout +<BR><CODE>getpid()</CODE> — return the process identification number +<BR><CODE>kill(i1, i2)</CODE> — send a signal to a process +<BR><CODE>lgconv(i)</CODE> — convert a large integer to a string +<BR><CODE>tconnect(s, i)</CODE> — connect a file to a TCP port +<BR><CODE>umask(i)</CODE> — change the process permission mask +</BLOCKQUOTE> + +<P> The full set of functions can be found in the +library's <CODE>cfuncs</CODE> directory. +Documentation and code are also +<A HREF="http://www.cs.arizona.edu/icon/library/fcfuncs.htm">available +on line</A>. +These functions are available automatically to an Icon program +that includes <CODE>link cfunc</CODE>. +The <CODE>bitcount()</CODE> function +is a good example for detailed examination. + + +<H2> Loading a function </H2> + +<P> The built-in Icon function <CODE>loadfunc(libname, funcname)</CODE> +loads the C function <CODE>funcname()</CODE> from +the library file <CODE>libname</CODE> and returns a procedure +value. If the function cannot be loaded, the program is terminated. + +<P> If <CODE>loadfunc(libname, "myfunc")</CODE> produces <CODE>p</CODE>, +then +<UL> +<LI><CODE>p(</CODE>arguments<CODE>)</CODE> calls <CODE>myfunc()</CODE> + with a list of arguments +<LI><CODE>type(p)</CODE> returns <CODE>"procedure"</CODE> +<LI><CODE>image(p)</CODE> returns <CODE>"function myfunc"</CODE> +<LI><CODE>proc("myfunc")</CODE> returns <CODE>p</CODE> +<LI><CODE>proc("myfunc", 0)</CODE> fails +</UL> + +<P> The following program loads the function +<CODE>bitcount()</CODE> and assigns it to a global variable of the +same name. Assigning it to a global variable makes +it available to other procedures, although that's not +needed here. The <CODE>bitcount()</CODE> function returns the +number of bits that are set in the binary representation of an integer. +<BLOCKQUOTE><PRE> +$define Library "/icon/bin/libcfunc.so" +global bitcount + +procedure main() + local i + bitcount := loadfunc(Library, "bitcount") + every i := 250 to 260 do + write(i, " ", bitcount(i)) +end +</PRE></BLOCKQUOTE> + +<P> When this program is run, it lists the integers +from 250 to 260 along with their bit counts: +<BLOCKQUOTE><PRE> +250 6 +251 7 +252 6 +253 7 +254 7 +255 8 +256 1 +257 2 +258 2 +259 3 +260 2 +</PRE></BLOCKQUOTE> + + +<H2> Loading from a path </H2> + +<P> Embedding a file name such as <CODE>/icon/bin/libcfunc.so</CODE> +in the program is undesirable. An alternative is for the +program to find the library file +using information from the program environment. + +<P> The Icon library procedure +<CODE>pathload(libname, funcname)</CODE> +searches the set of directories given by +the <CODE>FPATH</CODE> environment variable to find <CODE>libname</CODE> +and load <CODE>funcname</CODE>. +As is usual in Icon path searching, the current +directory is searched first. If the +function cannot be loaded, the program is terminated. + +<P> The <CODE>pathload()</CODE> procedure is included +by linking <CODE>pathfind</CODE> from the Icon program library. Using +<CODE>pathload()</CODE>, the example program becomes: +<BLOCKQUOTE><PRE> +$define Library "libcfunc.so" +link pathfind +global bitcount + +procedure main() + local i + bitcount := pathload(Library, "bitcount") + every i := 250 to 260 do + write(i, " ", bitcount(i)) +end +</PRE></BLOCKQUOTE> + +<P> The default <CODE>FPATH</CODE> includes the current directory +and the installed Icon program library directory. +To find a library located elsewhere, +<CODE>FPATH</CODE> must be set explicitly before the program is run. + + +<H2> Implicit function loading </H2> + +<P> It is possible to encapsulate the loading process so that the body of +an Icon program is unaware +that it is calling a C function. Consider this example: +<BLOCKQUOTE><PRE> +$define Library "libcfunc.so" +link pathfind + +procedure main() + local i + every i := 250 to 260 do + write(i, " ", bitcount(i)) +end + +procedure bitcount(n) + bitcount := pathload(Library, "bitcount") + return bitcount(n) +end +</PRE></BLOCKQUOTE> + +<P> First of all, notice that there is no longer a +global declaration for <CODE>bitcount</CODE>, and that the main +procedure no longer calls <CODE>pathload()</CODE>. As far as the +main procedure is concerned, <CODE>bitcount()</CODE> is just +another procedure to call, with no special requirements. This is a nice +simplification. + +<P> The new <CODE>bitcount()</CODE> procedure is a bit tricky, +though. To understand it, you must know that an +Icon procedure declaration creates a global variable with an initial +value of that procedure. A +global variable is subject to assignment. + +<P> When <CODE>main()</CODE> calls <CODE>bitcount()</CODE> for the first time, +the <CODE>bitcount()</CODE> procedure loads the <CODE>bitcount()</CODE> +C function from the library. The result is assigned to the +global variable <CODE>bitcount</CODE>, replacing the current procedure value. +Consequently, all subsequent calls +to <CODE>bitcount()</CODE> use the loaded function. + +<P> The first call to <CODE>bitcount()</CODE> remains incomplete +after loading the function; the bits of <CODE>n</CODE> still must be +counted. So, following loading, the procedure calls +<CODE>bitcount(n)</CODE>. Although this looks like a recursive +call, it isn't — the call uses the current value of the +global variable <CODE>bitcount</CODE>, and so it calls the loaded C +function. The bits of <CODE>n</CODE> are counted and returned, +completing the first call. + +<P> After the first time, calls to <CODE>bitcount()</CODE> +go directly to the loaded code. The Icon procedure +<CODE>bitcount()</CODE> is no longer accessible. + + +<H2> Implicit library loading </H2> + +<P> The Icon program library provides an implicit loading procedure for +each of the C functions +in the library. Small procedures like the <CODE>bitcount()</CODE> +procedure shown above are included by linking +<CODE>cfunc</CODE>. Using the library interface procedure, our +example now can be simplified to this: +<BLOCKQUOTE><PRE> +link cfunc + +procedure main() + local i + every i := 250 to 260 do + write(i, " ", bitcount(i)) +end +</PRE></BLOCKQUOTE> + +<P> The <CODE>link cfunc</CODE> declaration is the only hint that +<CODE>bitcount()</CODE> is written in C. + + +<H2> Making connections </H2> + +<P> The bit counting example doesn't really illustrate the full potential +of using C functions in an +Icon program. Bit counting, after all, can be done in +Icon. Here's something that can't. + +<P> The library function +<CODE>tconnect(host, port)</CODE> establishes a TCP connection +to a specified port +number on an Internet host. TCP is a communication protocol used by +telnet programs, news servers, web servers, and many other network +services. + +<P> The following program makes a connection +to the Icon web server and writes the contents of +the Icon home page — in its original HTML markup +language, of course. +<BLOCKQUOTE><PRE> +link cfunc + +procedure main() + local f + f := tconnect("www.cs.arizona.edu", 80) + writes(f, "GET /icon/ HTTP/1.0\n\n") + flush(f) + seek(f, 1) + while write(read(f)) +end +</PRE></BLOCKQUOTE> + +<P> The <CODE>tconnect()</CODE> call establishes the connection +and returns a file that is open for both input and +output. The internet host <CODE>www.cs.arizona.edu</CODE> is +the web server for the University of Arizona's +Department of Computer Science. +(Port 80 is the standard web server port number.) +The program then transmits a request for the +<CODE>/icon/</CODE> web page. The details of the request string +are specified by the +<A HREF="http://www.w3.org/Protocols/rfc2616/rfc2616.html">Hypertext +Transfer Protocol</A>, not discussed here. + +<P> The <CODE>flush()</CODE> call ensures that all the data is +actually sent, and then the <CODE>seek()</CODE> call resets the file +in preparation for a switch from output to input. In +this situation <CODE>seek()</CODE> does not actually reposition +the file, but it's required when switching modes. + +<P> Finally, lines are read and echoed until an +end-of-file is received. + + +<H2> Writing loadable C functions </H2> + +<P> Now consider the construction of library functions. +Because the Icon system expects C functions +to implement a certain interface, dynamic loading +usually requires specially written C functions. In +general, it is not possible to use an existing C +function without writing an intermediate "glue" +function. + +<P> C functions must deal with the data types +used by the Icon run-time system, notably the +"descriptors" that represent all Icon values. While +an understanding of +<A HREF="http://www.cs.arizona.edu/icon/ibsale.htm">the +Icon run-time system</A> is helpful, +it is possible to create useful functions by +modeling them after existing library functions. +Integer and string values are most easily handled. + +<P> A loadable C function has the prototype +<BLOCKQUOTE><CODE>int funcname(int argc, descriptor *argv)</CODE></BLOCKQUOTE> +where <CODE>argc</CODE> is the number of arguments and <CODE>argv</CODE> is +an array of argument descriptors. +The first element, <CODE>argv[0]</CODE>, is used to return an Icon value, and +is initialized to a descriptor for the null value. This +element is not included in the count <CODE>argc</CODE>. The +actual arguments begin with <CODE>argv[1]</CODE>. + +<P> If the C function returns zero, the call from +Icon succeeds. A negative value indicates failure. If +a positive value is returned, it is interpreted as an +error number and a fatal error with that number is +signalled. In this case, if <CODE>argv[0]</CODE> is non-null, it is +reported as the "offending value". There is no way +for a C function to suspend, and no way to indicate +a null value as an offending value in the case of an +error. + + +<H2> Interface macros </H2> + +<P> The C file <CODE>icall.h</CODE> contains a set of macros for +use in writing loadable functions. Documentation +is included as comments. This file can be found in the +<CODE>cfuncs</CODE> directory in the source code of the Icon +program library. Alternatively, it can be loaded +<A HREF="http://www.cs.arizona.edu/icon/library/src/cfuncs/icall.h">from +the web</A>. Macros are provided for: +<UL> +<LI>inspecting the type of an Icon value +<LI>validating the type of an argument +<LI>converting an Icon value into a C value +<LI>returning a C value in Icon form +<LI>failing or signaling an error +</UL> + +<P> Most macros deal with integers or strings. +Some support also is provided for handling real +and file values. +The macros expect the C arguments to be declared with the +names of <CODE>argc</CODE> and <CODE>argv</CODE>. + + +<H2> Counting bits, again </H2> + +<P> For a concrete example of a C function, consider the source code +of the <CODE>bitcount()</CODE> function used earlier: +<BLOCKQUOTE><PRE> +#include "icall.h" + +int bitcount(int argc, descriptor *argv) +{ + unsigned long v; + int n; + ArgInteger(1); + v = IntegerVal(argv[1]); + n = 0; + while (v != 0) { + n += v & 1; + v >>= 1; + } + RetInteger(n); +} +</PRE></BLOCKQUOTE> + +<P> Like all loadable functions, <CODE>bitcount()</CODE> is an +integer function with two parameters, <CODE>argc</CODE> and +<CODE>argv</CODE>. + +<P> The <CODE>ArgInteger</CODE> macro call verifies that argument 1 is a simple +integer. (Large integers are +typically rejected by C functions because of the +extra work involved.) If argument 1 is missing or +has the wrong type, <CODE>ArgInteger</CODE> makes the function +return error code 101 (integer expected or out of +range). + +<P> The <CODE>IntegerVal</CODE> macro call extracts the value +of the first argument. + +<P> In each pass through the <CODE>while</CODE> loop, the low order bit of +<CODE>v</CODE> is +extracted (<CODE>v & 1</CODE>), added to <CODE>n</CODE>, and +shifted off (<CODE>v >>= 1</CODE>). When no more nonzero bits +are left, the loop exits. Note that <CODE>v</CODE> is declared +unsigned to ensure that only zero bits are inserted +by the shift operation. + +<P> The <CODE>RetInteger</CODE> macro call returns the value +of <CODE>n</CODE> as an Icon integer. + + +<H2> External data values </H2> + +<P> Loadable functions can create and return data structures +that are treated as an opaque <CODE>external</CODE> type by Icon. +The use of external types is described <A HREF="extlvals.htm">separately</A>. + + +<H2> Preparing a library </H2> + +<P> To be used in an Icon program, a C function +must be built and installed in a library. Compilation comes first, +usually involving a command such as +<BLOCKQUOTE><CODE>cc –c bitcount.c</CODE></BLOCKQUOTE> +to produce an object file <CODE>bitcount.o</CODE>. +The <CODE>–c</CODE> option causes a relocatable object file +to be produced instead of a stand-alone executable program. +If <CODE>icall.h</CODE> is not in the current directory, +an additional option may be needed to specify its location. +Other options, such as optimization options, also could be specified. + +<P> A C function can be loaded only from a "shared library". +Even if there is just one function, it must be placed in a library. +Library names conventionally end with a <CODE>.so</CODE> suffix. + +<P> It seems that every system has a different +way to create libraries, usually involving special +flags to <CODE>cc</CODE> or <CODE>ld</CODE>. +The shell script <CODE>mklib.sh</CODE> +embodies our understanding of shared library creation. +It takes one argument naming the library to be created and one or more +additional arguments listing object file names. +For example, the command +<BLOCKQUOTE><CODE>mklib.sh mylib.so bitcount.o</CODE></BLOCKQUOTE> +creates a file <CODE>mylib.so</CODE> containing the functions read +from <CODE>bitcount.o</CODE>. +Like <CODE>icall.h</CODE>, <CODE>mklib.sh</CODE> is available in +the program library source code or +<A HREF="http://www.cs.arizona.edu/icon/library/src/cfuncs/mklib.sh">from +the web</A>. + + +<H2> Summary </H2> + +<P> +<UL> +<LI> Icon programs can load and call functions written in C. +<LI> The C functions must be tailored to Icon's requirements. +<LI> Each function must be loaded before it can be called. +<LI> A simple Icon procedure can be used to hide the loading details. +<LI> <CODE>pathload()</CODE> searches <CODE>FPATH</CODE> + to find a function library. +<LI> C functions can embed data in opaque <CODE>external</CODE> values. +<LI> Some useful functions are provided in the Icon program library. +</UL> + +<P> <HR> + +</BODY> +</HTML> diff --git a/doc/cygwin.htm b/doc/cygwin.htm index 88e0a54..c206af1 100644 --- a/doc/cygwin.htm +++ b/doc/cygwin.htm @@ -16,10 +16,10 @@ ALT="[Icon home]" WIDTH=128 HEIGHT=144 BORDER=0 ALIGN=RIGHT> </A> <BR> <SMALL> Department of Computer Science </SMALL> <BR> <SMALL> The University of Arizona </SMALL> -<P> <SMALL> www.cs.arizona.edu/icon/v943/cygwin.htm +<P> <SMALL> www.cs.arizona.edu/icon/v950/cygwin.htm <BR> -Last updated November 8, 2005 </SMALL> -<!-- $Id: cygwin.htm,v 1.5 2005/11/08 23:24:34 gmt Exp $ --> +Last updated November 8, 2009</SMALL> +<!-- $Id: cygwin.htm,v 1.11 2009/11/08 21:53:08 gmt Exp $ --> <H2> Introduction </H2> @@ -38,12 +38,20 @@ Successful use of Cygwin requires familiarity with both Windows and Unix. <P> This document describes some of the peculiarities of the Cygwin -port of Version 9.4 of Icon. +port of Icon. These differences are not necessarily identified in other documentation. <H2> Building Icon </H2> +<P> Icon is built in a Cygwin shell window using the same process as on +on other platforms. +See the <A HREF=build.htm>installation documentation</A> for instructions. +There are two possible choices for configuration name: +The <CODE>cygwin</CODE> configuration uses the native Windows graphics system; +the <CODE>xcygwin</CODE> configuration uses the X window system and thus +is closer to other Unix implementations of Icon. + <P> The Cygwin package is available from <A HREF="http://www.cygwin.com/">www.cygwin.com</A>. A custom installation of the Cygwin system is required; @@ -52,14 +60,8 @@ insufficient for building software. Icon requires a C compiler and the usual tools and utilities available on a standard POSIX development system; these are found in the <CODE>gcc-core</CODE> and <CODE>make</CODE> packages. -The <CODE>xorg</CODE> family of packages is also needed -to build Icon with graphics enabled. - -<P> Icon is built in a Cygwin shell window. -The process is the same as on other platforms -and uses the configuration named <CODE>cygwin</CODE>. -See the <A HREF=build.htm>installation documentation</A> -for instructions on building Icon. +The <CODE>xinit</CODE> and <CODE>libXt-devel</CODE> packages are also needed +to build the <CODE>xcygwin</CODE> configuration with graphics enabled. <H2> Running Icon programs </H2> @@ -74,29 +76,34 @@ and <A HREF=icont.txt><CODE>icont</CODE></A> describe the command options in a traditionally cryptic manner. -<H2> Interpreter path </H2> +<H2> Interpreter path and environment</H2> <P> Icon programs require an interpreter for execution. On Windows, the path of the interpreter is not embedded in an executable program. The program must be able to find -<CODE>iconx.exe</CODE> in one of these locations: -<UL> - <LI> in the file named by the <CODE>ICONX</CODE> environment variable - <LI> in the same directory as the executable program - <LI> in the search path -</UL> +<CODE>iconx.exe</CODE> in the search path. + +<P> The Cygwin X server must be running, with a correct <CODE>DISPLAY</CODE> +variable in the environment, to execute graphics programs built by the +<CODE>xcygwin</CODE> configuration of Icon. + +<P> When the environment is correctly set, +with <CODE>cygwin1.dll</CODE> in the Windows path, +a compiled Icon program may be run from the Cygwin shell or by +double-clicking its graphical icon. <H2> Extra built-in functions </H2> <P> For compatibility with an earlier port of Icon to Windows, -this implementation includes some extra built-in functions. -The functions are described in section 6.2 of +the <CODE>cygwin</CODE> configuration includes some extra built-in functions. +These are described in section 6.2 of <A HREF="http://www.cs.arizona.edu/icon/docs/ipd271.htm">IPD271</A>, which documents that earlier port. <P> These unsupported functions are not part of Icon on other platforms, +nor of the <CODE>xcygwin</CODE> configuration, so their use renders a program non-portable. @@ -104,25 +111,20 @@ so their use renders a program non-portable. <P> The symbols <CODE>_MS_WINDOWS</CODE> and <CODE>_CYGWIN</CODE> are defined by the Icon preprocessor. +The symbol <CODE>_UNIX</CODE> is not defined. The symbol <CODE>_GRAPHICS</CODE> is defined if Icon is built with -graphics enabled. -The symbols <CODE>_UNIX</CODE> and <CODE>_X_WINDOW_SYSTEM</CODE> -are not defined. +graphics enabled; +the symbol <CODE>_X_WINDOW_SYSTEM</CODE> is also defined +in the <CODE>xcygwin</CODE> configuration. The corresponding strings are produced or omitted, as appropriate, by the <CODE>&features</CODE> keyword. -<H2> No dynamic loading </H2> - -The dynamic loading interface — <CODE>loadfunc()</CODE> — -is not implemented. - - <H2> Known bugs </H2> <UL> - <LI>Some Unix dependencies cause tests <CODE>io</CODE>, <CODE>tpp</CODE>, - and <CODE>opts</CODE> to fail. + <LI>Some Unix dependencies cause the <CODE>tpp</CODE> + and <CODE>opts</CODE> tests to fail. <LI> Resizing a window sends a large number of events to the program. </UL> diff --git a/doc/docguide.htm b/doc/docguide.htm index 9bb4121..6601f1b 100644 --- a/doc/docguide.htm +++ b/doc/docguide.htm @@ -16,9 +16,9 @@ ALT="[Icon home]" WIDTH=128 HEIGHT=144 BORDER=0 ALIGN=RIGHT> </A> <BR> <SMALL> Department of Computer Science </SMALL> <BR> <SMALL> The University of Arizona </SMALL> -<P> <SMALL> www.cs.arizona.edu/icon/v943/docguide.htm -<BR> Last updated November 9, 2005 </SMALL> -<!-- $Id: docguide.htm,v 1.28 2005/11/09 18:03:59 gmt Exp $ --> +<P> <SMALL> www.cs.arizona.edu/icon/v950/docguide.htm +<BR> Last updated November 16, 2009</SMALL> +<!-- $Id: docguide.htm,v 1.33 2009/11/16 22:11:13 gmt Exp $ --> <H2> Introduction </H2> @@ -26,14 +26,18 @@ ALT="[Icon home]" WIDTH=128 HEIGHT=144 BORDER=0 ALIGN=RIGHT> </A> <P> Icon is distributed with a small set of documentation pages: <UL> <LI> This documentation guide +<LI> The <A href="icon.txt"><CODE>icon</CODE></A> + and <A href="icont.txt"><CODE>icont</CODE></A> commands <LI> <A HREF=relnotes.htm> Release notes</A> +<LI> <A HREF=macintosh.htm> Icon on Macintosh</A> +<LI> <A HREF=cygwin.htm> Icon on Cygwin</A> +<LI> <A HREF=faq.htm> Frequently asked questions</A> <LI> <A HREF=install.htm> Installation instructions</A> (for binary releases) <LI> <A HREF=build.htm> Build instructions</A> (for source releases) -<LI> <A HREF=port.htm> Porting instructions</A> <LI> <A HREF=files.htm> File organization</A> -<LI> <A HREF=macintosh.htm> Icon on Macintosh</A> -<LI> <A HREF=cygwin.htm> Icon on Cygwin</A> -<LI> <A HREF=faq.htm> Frequently asked questions about Icon</A> +<LI> <A HREF=port.htm> Porting instructions</A> +<LI> <A HREF=cfuncs.htm> Loading C functions dynamically</A> +<LI> <A HREF=extlvals.htm> External values</A> </UL> <P> This guide provides an overview of additional available information. @@ -124,6 +128,7 @@ of the Icon books: <LI> Path searching improvements <LI> Reading directory contents <LI> Reading foreign text files + <LI> <A HREF="extlvals.htm">External values</A> </UL> These features are more fully described in the <A HREF=relnotes.htm>release notes</A>. @@ -168,15 +173,6 @@ http://www.cs.arizona.edu/icon/docs/ipd239.htm</A> <A HREF="http://www.cs.arizona.edu/icon/ftp/doc/ipd261.pdf"> www.cs.arizona.edu/icon/ftp/doc/ipd261.pdf</A> (PDF). -<P> The construction of loadable C functions is described in -the <CITE>Dynamic Loading</CITE> section of IPD240, -<A HREF="http://www.cs.arizona.edu/icon/docs/ipd240.htm"> -www.cs.arizona.edu/icon/docs/ipd240.htm</A>. -Also see the examples in the -<A HREF="http://www.cs.arizona.edu/icon/library/ccfuncs.htm"> -<CODE>cfuncs</CODE></A> section of the library, which use -a simpler set of interface macros. - <H2> Technical Reports </H2> @@ -186,11 +182,11 @@ The index is found at <A HREF="http://www.cs.arizona.edu/icon/docs/docs.htm"> www.cs.arizona.edu/icon/docs/docs.htm</A>. -<P> Many of these reports are historical and describe past research -experiments. -Those cited above are among the most current, +<P> Most of these reports are historical and +many describe past research experiments. +The reports cited above are among the most current, although they may not be completely correct with respect -to Version 9.4. +to Version 9.5. <H2> Discussion Group </H2> diff --git a/doc/extlvals.htm b/doc/extlvals.htm new file mode 100644 index 0000000..2229067 --- /dev/null +++ b/doc/extlvals.htm @@ -0,0 +1,288 @@ +<!doctype html public "-//W3C//DTD HTML 4.01 Transitional//EN"> +<HTML> +<HEAD> + <TITLE>Icon External Values</TITLE> + <LINK REL="STYLESHEET" TYPE="text/css" HREF="istyle.css"> + <LINK REL="SHORTCUT ICON" HREF="shortcut.gif"> +</HEAD> +<BODY> + +<P><A HREF="http://www.cs.arizona.edu/icon/"> <IMG SRC="wwwcube.gif" +ALT="[Icon home]" WIDTH=128 HEIGHT=144 BORDER=0 ALIGN=RIGHT> </A> + +<H1> Icon External Values </H1> + +<P> Carl Sturtivant +<BR> <SMALL> Computer Science & Engineering Department </SMALL> +<BR> <SMALL> University of Minnesota </SMALL> + +<P> Gregg M. Townsend +<BR> <SMALL> Department of Computer Science </SMALL> +<BR> <SMALL> The University of Arizona </SMALL> + +<P> <SMALL> www.cs.arizona.edu/icon/v950/extlvals.htm +<BR> +Last updated March 25, 2010</SMALL> +<!-- $Id: extlvals.htm,v 1.18 2010/03/25 23:33:10 gmt Exp $ --> + + +<H2> Introduction </H2> + + +<P> External values provide a way for +<A HREF="cfuncs.htm">dynamically loaded C functions</A> +to create and return opaque data structures to an Icon program. +This allows state to be maintained across multiple calls of +loaded functions. + +<P> The creation of an external value in C defines +not just the data itself but also some related attributes. +These control the sorting behavior, image, and other such aspects. +Icon provides defaults and also adds a serial number +similar to those of lists, sets, and tables. + +<P> The specification of attributes effectively creates a number +of distinct types. +Each loadable library can define the types it needs for its own purposes. +From an object-oriented perspective, these can be seen as subtypes +of a common <CODE>external</CODE> type. + + +<H2> External Values in an Icon Program </H2> + +<P> External values are opaque to Icon. They are <EM>created</EM> only by +dynamically +loaded C functions, any of which in turn may have access to their internals. In +this way a library of Icon functions to work with a specific kind of external +value is possible. However, such values can be seen and manipulated (assigned, +passed to procedures or functions, sorted, copied, etc.) in Icon. The +behavior of an external value in Icon may be modified to some extent by the +implementation of the dynamically loaded function that is used to create it, as +described below. + +<P> In what follows let <CODE>E</CODE>, <CODE>E1</CODE>, and <CODE>E2</CODE> +be external values +produced by some loaded function or functions. Icon prescribes the following +default behavior of such values, which is exhibited if the functions that +created them did not override such at the time of creation. Otherwise behavior +in the following contexts is determined by the external values' creators. + +<P> External values always sort after values of all other types. +Within themselves external +values are first sorted by type name (which is a set by the creator, +is returned by the Icon function <CODE>type</CODE>, +and specifies a subtype of the external type). +The default sort within such a subtype is by serial number. Only sorting +within a subtype (i.e., externals with a specific type name) can be overridden +by the creator. See the next section for a description of the relevant C +internals. The default behavior follows. + +<BLOCKQUOTE><DL> +<DT><CODE>type(E)</CODE> + <DD>returns the string <CODE>"external"</CODE> +<DT><CODE>image(E)</CODE> + <DD>returns a string indicating the type, serial number, + and the number of data words, + <I>e.g.</I> <CODE>"external_12(3)"</CODE> +<DT><CODE>copy(E)</CODE> + <DD>returns <CODE>E</CODE> itself without copying +<DT><CODE>sort()</CODE> + <DD>external values sort first by type name and then by serial number +<DT><CODE>E1 === E2</CODE> + <DD>produces <CODE>E1</CODE> when <CODE>E1</CODE> and <CODE>E2</CODE> + are the same external object; otherwise fails +<DT><CODE>E1 ~=== E2</CODE> + <DD>produces <CODE>E2</CODE> when <CODE>E1</CODE> and <CODE>E2</CODE> + are distinct; otherwise fails +</DL></BLOCKQUOTE> + + +<H2> Creating and Using External Values in C </H2> + +<P>These next sections describe the C interface for a reader who is +familiar with the use of loadable functions. + +<P> An Icon external value is implemented by a descriptor that points +to an external block containing several components. +The data area and the function list are the most important of these. + +<P> An integer word count indicates the size of the data area. +This is specified when the external block is created. +Often external data is a single pointer to other data (a handle) +and so only one word is required. + +<P> The function list allows the programmer to override, +for all values of the same external type, +the default behaviors listed in the previous section. +The list is a callback table pointing to programmer-defined C functions +as described in more detail below. +The function list also acts as a unique type identifier, because external +values with different function lists behave as values of distinct type. + +<P> A dynamically loaded C function allocates an external value by including +<CODE>ipl/cfuncs/icall.h</CODE> and calling <CODE>alcexternal</CODE>: + +<BLOCKQUOTE> +<DL> +<DT> +<CODE>externalblock *alcexternal</CODE>(long size, funclist *funcs, void *data) +</DT><DD> + allocates and returns a pointer to an external block. + <BR><VAR>size</VAR> specifies the number of bytes + in the entire external block (and by implication + the size of the data block inside it). + <BR><VAR>funcs</VAR>, if not null, specifies a list of functions to + override the default behavior. See the next section. + <BR><VAR>data</VAR>, if not null, specifies the location of data + that is copied in to initialize the data block (until it is full). +</DD></DL> +</BLOCKQUOTE> + +<P> +A typical call might be +<BLOCKQUOTE> + blk = alcexternal(sizeof(externalblock) + sizeof(mydata), funcs, &mydata); +</BLOCKQUOTE> +The result is returned to Icon by the macro call +<CODE>RetExternal(</CODE>blk<CODE>)</CODE>. +The block may eventually be freed by garbage collection if it +is not saved or if it later becomes inaccessible to the Icon program. + +<P> A loadable function that accepts an external value as an argument can call +<BLOCKQUOTE> + ArgExternal(i,f); +</BLOCKQUOTE> +to validate argv[i] as an external value of the type associated +with function list f, and can then call +<BLOCKQUOTE> + blk = ExternalBlock(i); +</BLOCKQUOTE> +to get the address of the associated external block; +the associated data is at blk–>data. + +<P>A more complete example is found in the file +<CODE>ipl/cfuncs/external.c</CODE>. + + +<H2> The Function List Passed to alcexternal </H2> + +<P> The function list associated with an external value is a struct +containing pointers to C functions. +It is reminiscent of a "dispatch table" or "class pointer" +for dynamic method calls in an implementation of an object oriented programming +language. Indeed an Icon external value is very much like a traditional object +with its own data and methods. Typically such a function list would be static +and shared among many Icon external values of the same kind ("class" or "type"). + +<P> Every external value has a function list; a default list is supplied +if NULL is passed to alcexternal. A null entry within a function list +produces the default behavior for the associated action. + +<P> Functions in the list use the same interface as loadable C functions. +Incoming arguments are passed beginning at argv[1]. +A result is produced by storing it in argv[0] +and returning 0 as the outcome of the function. +When extlcmp is called, argc has a value of 2; +for the other functions, argc is 1. + +<P> The possible custom functions are as follows: + +<BLOCKQUOTE> +<DL> + +<DT> +<CODE>int extlcmp</CODE>(int argc, descriptor *argv) +</DT><DD> +returns an Icon integer +for use in sorting two external values that both have this function list +and are therefore considered to be of the same external subtype. +The function result should be negative if the first external value is +deemed less than the second, zero if they are deemed equal, and positive +if the first is deemed greater than the second. +This overrides the default behavior of the <CODE>sort</CODE> function +which compares serial numbers. +</DD> + +<DT> +<CODE>int extlcopy</CODE>(int argc, descriptor *argv) +</DT><DD> +returns an external value defined as a copy of its argument. +This overrides the default behavior of the <CODE>copy</CODE> function, +which is to return another reference to the external value without copying. +</DD> + +<DT> +<CODE>int extlname</CODE>(int argc, descriptor *argv) +</DT><DD> +returns an Icon string naming the type of the external value. +This overrides the default behavior of the <CODE>type</CODE> function, and thus +also affects the ordering relative to other external values when sorting. +</DD> + +<DT> +<CODE>int extlimage</CODE>(int argc, descriptor *argv) +</DT><DD> +returns an Icon string to serve as the image of the external value. +This overrides the default behavior of the <CODE>image</CODE> function. +</DD> + +</DL> +</BLOCKQUOTE> + + +<H2> Implementation Details </H2> + +<SMALL>This section supplements the Icon +<A HREF="http://www.cs.arizona.edu/icon/ibsale.htm"> +implementation book</A>.</SMALL> + +<P> A descriptor for an external value has a vword containing the bit pattern +D_External which contains the value T_External indicating the external type, +along with the bit F_Nqual indicating that the value is not a string and the +bit F_Ptr indicating to the garbage collector that the dword is a pointer that +needs tending. The dword contains a pointer to an external block. This block is +implemented as a C struct with a pointer to a function block C struct as +follows. The structs below, along with types word and descriptor, +are defined in ipl/cfuncs/icall.h. + +<PRE> +typedef struct funclist { /* list of user defined callbacks */ + int (*extlcmp) (int argc, descriptor *argv); /* compare */ + int (*extlcopy) (int argc, descriptor *argv); /* copy */ + int (*extlname) (int argc, descriptor *argv); /* type name */ + int (*extlimage) (int argc, descriptor *argv); /* image */ +} funclist; + +typedef struct externalblock { + word title; /* the block header, including type */ + word size; /* the number of bytes in the block */ + word id; /* the serial number */ + funclist *funcs; /* pointer to the callback list */ + word data[]; /* arbitrary custom data */ +} externalblock; +</PRE> + +<P> A call of alcexternal initializes all fields of an external block. +Data is copied without interpretation, and the function +list pointer is stored. The header is assigned an appropriate constant for the +garbage collector, and the size is set. alcexternal maintains a static +count of the number of external blocks allocated, and this is incremented and +assigned to id. + +<P> The following error code numbers are assigned for use with external values: +<BLOCKQUOTE><TABLE> +<TR><TH>errno<TH>errtext<TH>meaning +<TR><TD><CODE>131</CODE><TD><CODE>external expected</CODE> + <TD>not an external value +<TR><TD><CODE>132</CODE><TD><CODE>incorrect external type</CODE> + <TD>external of wrong flavor +<TR><TD><CODE>133</CODE><TD><CODE>invalid external value</CODE> + <TD>right flavor in wrong context +<TR><TD><CODE>134</CODE><TD><CODE>malformed external value</CODE> + <TD>data is bogus, not just inappropriate +</TABLE></BLOCKQUOTE> + +<P> <HR> + +</BODY> +</HTML> diff --git a/doc/faq.htm b/doc/faq.htm index 50175fc..ad3d10d 100644 --- a/doc/faq.htm +++ b/doc/faq.htm @@ -11,8 +11,8 @@ <H1>Frequently Asked Questions about the Icon programming language</H1> <A HREF="http://www.cs.arizona.edu/icon/faq.htm"> www.cs.arizona.edu/icon/faq.htm</A> -<BR>Last updated November 14, 2005<BR> -<!-- $Id: faq.htm,v 1.45 2005/11/14 16:24:44 gmt Exp $ --> +<BR>Last updated April 12, 2010<BR> +<!-- $Id: faq.htm,v 1.57 2010/04/12 20:39:24 gmt Exp $ --> <P><STRONG>Learning about Icon</STRONG><BR> <A HREF="#whatsicon">A1. What is Icon?</A><BR> @@ -124,12 +124,15 @@ What are Icon's distinguishing characteristics?</H3> <H3><A NAME="library">A4.</A> What is the Icon program library?</H3> <P> The library is a collection of programs and procedures written in Icon. -User contributions are welcome and form a significant portion of the library. +User contributions form a significant portion of the library. <P> Library procedures effectively augment the built-in functions available to an Icon program. A wide variety of procedures currently exists, and most graphically-based programs are built around library procedures. +The <A HREF="http://www.cs.arizona.edu/icon/library/src/procs/core.icn">core</A> +and <A HREF="http://www.cs.arizona.edu/icon/library/src/gprocs/graphics.icn"> +graphics core</A> modules are the most carefully vetted. <P> The programs in the library range from simple demonstrations to handy tools to complex graphical applications. @@ -161,6 +164,13 @@ Here are some good places to start. <A HREF="http://www.nmt.edu/tcc/help/lang/icon/"> www.nmt.edu/tcc/help/lang/icon</A> </UL> +<P> +For the graphics facilities: +<UL> +<LI> The Icon Project Overview: + <A href="http://www.cs.arizona.edu/icon/ftp/doc/ipd281.pdf"> + www.cs.arizona.edu/icon/ftp/doc/ipd281.pdf</A> +</UL> <H3><A NAME="examples">A6.</A> Where are some simple examples?</H3> <P> @@ -203,7 +213,7 @@ describe subsequent changes. Printed copies of the <CITE>Language</CITE> and <CITE>Graphics</CITE> books are available from Jeffery Systems -(<A HREF="http://www.zianet.com/jeffery/books/">www.zianet.com/jeffery/books</A>). +(<A HREF="http://unicon.org/books/">http://unicon.org/books/</A>). All three books can be downloaded at no charge from the Icon books page, <A HREF="http://www.cs.arizona.edu/icon/books.htm"> www.cs.arizona.edu/icon/books.htm</A>. @@ -219,39 +229,39 @@ www.cs.arizona.edu/icon/library/ipl.htm</A>. <P> There is a large amount of additional information at the Icon web site, -<A HREF="http://www.cs.arizona.edu/icon/">www.cs.arizona.edu/icon</A>. +<A HREF="http://www.cs.arizona.edu/icon/">www.cs.arizona.edu/icon</A>, +including complete sets of back issues of the +<A HREF="http://www.cs.arizona.edu/icon/inl/inl.htm"> +<CITE>Icon Newsletter</CITE></A> and +<A HREF="http://www.cs.arizona.edu/icon/analyst/ia.htm"> +<CITE>Icon Analyst</CITE></A>. <P><HR><H2>Implementations</H2> <H3><A NAME="platforms">B1.</A> What platforms support Icon?</H3> <P> -Current implementations with graphics support -are available for Unix (including Linux) and Windows. -The Unix implementation also runs on Darwin, -the Macintosh development environment, or the +The current implementation of Icon is a Unix implementation. +This includes Linux, BSD, Solaris, Macintosh, and the <A HREF="http://www.cygwin.com/">Cygwin</A> environment under Windows. -Older versions of Icon are available for some other systems. +Version 9.5 of Icon has been tested on all these platforms. +<P> +Older versions are available for Windows and some other systems. An alternative Java-based implementation for Unix, <A HREF="http://www.cs.arizona.edu/icon/jcon/">Jcon</A>, is also available. +<P> +None of these environments includes a window-based development environment. +While Icon programs can open windows and use graphics, +programming is done using Unix editors and other tools from a command shell. <H3><A NAME="getstarted">B2.</A> How do I get started with Icon?</H3> <P> -Version 9.4.3 of Icon for <STRONG>Unix</STRONG> can be downloaded from -<A HREF="http://www.cs.arizona.edu/icon/v943/"> -www.cs.arizona.edu/icon/v943</A>. +The current version of Icon for Unix can be downloaded from +<A HREF="http://www.cs.arizona.edu/icon/current/"> +www.cs.arizona.edu/icon/current</A>. Source and binary packages are available, each with the complete Icon program library. <P> -Version 9.3 of Icon for <STRONG>Windows</STRONG> is compatible -at the source level with version 9.4.3. -It can be downloaded from -<A HREF="http://www.cs.arizona.edu/icon/v93w.htm"> -www.cs.arizona.edu/icon/v93w.htm</A>. -The Version 9.4.3 library can be obtained separately from -<A HREF="http://www.cs.arizona.edu/icon/v943/"> -www.cs.arizona.edu/icon/v943</A>. -<P> For older implementations, start at <A HREF="http://www.cs.arizona.edu/icon/implver.htm"> www.cs.arizona.edu/icon/implver.htm</A>. @@ -268,14 +278,11 @@ but a Unicode version of Jcon might be possible. <H3><A NAME="iconc">B4.</A> What happened to the compiler?</H3> <P> -For a while, Unix distributions included both an interpreter and a compiler; -but the interpreter is is usually fast enough even for production work, and -most people found that using the compiler wasn't worth the extra compilation -time or the hassles involved. -We no longer advertise the compiler or produce binaries for it. -It is still part of the source code distribution, -and we have not deliberately broken it, -but we no longer support it and we cannot offer help if problems arise. +For a while, Unix distributions included both an interpreter and a compiler. +The compiler was an interesting research project but it has not been +maintained and is no longer supported. +The interpreter is much easier to use and is generally quite fast enough, +even for production applications. <P><HR><H2>Administration</H2> @@ -290,11 +297,9 @@ Department of Computer Science at the University of Arizona. <H3><A NAME="updates">C2.</A> How often is the on-line material updated?</H3> <P> -New material is added when it's available. -Established implementations usually are updated only when there's a -new version. -This typically is every year or two. -The Icon program library is updated on a similar schedule. +The Icon implementation is now in maintenance mode, with new releases +produced only when necessary. This typically happens every few years when a +change in the Gnu tools cause the source to stop building. <H3><A NAME="lineage">C3.</A> Where did Icon come from?</H3> <P> @@ -329,7 +334,7 @@ but there's no good solution to that problem. <P> We continue to use Icon on a daily basis, but no significant changes are planned. -We expect to support the Unix version for the forseeable future, +We expect to support the Unix version for the foreseeable future, and to distribute ports to other systems as supplied by volunteers. <P> The Unicon project is developing an object-oriented language based on Icon. @@ -364,10 +369,6 @@ For <STRONG>porting</STRONG> assistance or <STRONG>Unix</STRONG> problems, contact <A HREF="mailto:icon-project@cs.arizona.edu">icon-project@cs.arizona.edu</A>. <LI> -For problems with the <STRONG>Windows</STRONG> implementation, -contact the implementor, -<A HREF="mailto:jeffery@cs.nmsu.edu">jeffery@cs.nmsu.edu</A>. -<LI> For general information and additional documentation, visit the Icon web site: <A HREF="http://www.cs.arizona.edu/icon/">www.cs.arizona.edu/icon</A>. </UL> @@ -398,26 +399,21 @@ A simple reference suffices, as in it's not necessary to actually call it. <P> (Why does the linker remove unreferenced procedures? -Because this can save <EM>huge</EM> amounts of memory for -programs that use the library.) +To <EM>significantly</EM> reduce the memory requirements of +programs that use the library. +There was a time when this mattered.) <H3><A NAME="callc">E3.</A> How can I call a C function?</H3> <P> -You can't call an arbitrary C function, -but if you're willing to write a function to Icon's specifications, -there are two approaches. -Under Unix, which provides <CODE>loadfunc()</CODE>, -you can load one or more functions from a shared library, -and then treat them as if they had been written in Icon. +You can't call an arbitrary C function, but you can load and call one +that is written to Icon's specifications. +A tutorial appears in +<a href="http://www.cs.arizona.edu/icon/analyst/backiss/IA36.pdf"> +Icon Analyst 36</a>. Some examples can be found in the <A HREF="http://www.cs.arizona.edu/icon/library/ccfuncs.htm"> <CODE>cfuncs</CODE></A> and <CODE>packs/loadfuncs</CODE> directories of the Icon program library. -The more cumbersome approach is to add code to the Icon interpreter -and rebuild it; some hooks are provided for this purpose. -Both approaches are discussed in <CITE>Calling C Functions from Icon</CITE>, -<A HREF="http://www.cs.arizona.edu/icon/docs/ipd240.htm"> -www.cs.arizona.edu/icon/docs/ipd240.htm</A>. <P> The <A HREF="http://www.cs.arizona.edu/icon/jcon/">Jcon</A> implementation allows Icon programs to call Java code that is written to Jcon specifications. diff --git a/doc/faq.txt b/doc/faq.txt index 91b4eb9..8538984 100644 --- a/doc/faq.txt +++ b/doc/faq.txt @@ -1,8 +1,7 @@ - Frequently Asked Questions about the Icon programming language www.cs.arizona.edu/icon/faq.htm - Last updated November 14, 2005 + Last updated April 12, 2010 Learning about Icon A1. What is Icon? @@ -23,7 +22,7 @@ C1. What is the Icon Project? C2. How often is the on-line material updated? C3. Where did Icon come from? - C4. Where is Icon going? + C4. Where is Icon going? Support D1. Is there a users' group for Icon? @@ -41,41 +40,43 @@ Learning about Icon A1. What is Icon? Icon is a very high level general-purpose programming language with - extensive features for processing strings (text) and data structures. Icon - is an imperative, procedural language with a syntax that is reminiscent of C - and Pascal, but with semantics at a much higher level. + extensive features for processing strings (text) and data structures. + Icon is an imperative, procedural language with a syntax that is + reminiscent of C and Pascal, but with semantics at a much higher + level. Icon has a novel expression-evaluation mechanism that integrates goal-directed evaluation and backtracking with conventional control - structures. It has a string scanning facility for pattern matching that - avoids the tedious details usually associated with analyzing strings. Icon's - built-in data structures include sets and tables with associative lookup, - lists that can be used as vectors or stacks and queues, and records. + structures. It has a string scanning facility for pattern matching + that avoids the tedious details usually associated with analyzing + strings. Icon's built-in data structures include sets and tables with + associative lookup, lists that can be used as vectors or stacks and + queues, and records. Icon is a strongly, though not statically, typed language. It provides - transparent automatic type conversion: For example, if an integer is used in - an operation that requires a string, the integer is automatically converted - to a string. + transparent automatic type conversion: For example, if an integer is + used in an operation that requires a string, the integer is + automatically converted to a string. - Several implementations of Icon have high-level graphics facilities with an - easily programmed window interface. + Several implementations of Icon have high-level graphics facilities + with an easily programmed window interface. - Icon manages storage automatically. Objects are created as needed during - program execution and space is reclaimed by garbage collection as needed. - The sizes of strings and data structures are limited only by the amount of - available memory. + Icon manages storage automatically. Objects are created as needed + during program execution and space is reclaimed by garbage collection + as needed. The sizes of strings and data structures are limited only + by the amount of available memory. A2. What is Icon good for? As a general-purpose programming language with a large computational - repertoire, Icon can be used for most programming tasks. It's especially - strong at building software tools, for processing text, and for experimental - and research applications. + repertoire, Icon can be used for most programming tasks. It's + especially strong at building software tools, for processing text, and + for experimental and research applications. Icon is designed to make programming easy; it emphasizes the value of - programmer's time and the importance of getting programs to work quickly. - Consequently, Icon is used both for short, one-shot tasks and for very - complex applications. + programmer's time and the importance of getting programs to work + quickly. Consequently, Icon is used both for short, one-shot tasks and + for very complex applications. A3. What are Icon's distinguishing characteristics? @@ -85,7 +86,8 @@ Learning about Icon * Usually interpreted * Evolved from programming languages (vs. scripting languages) - * Procedural control flow plus generators and goal-directed evaluation + * Procedural control flow plus generators and goal-directed + evaluation * Values have types; variables are typeless, accept any value * Static scoping: global or (procedure) local @@ -97,14 +99,17 @@ Learning about Icon * Also has sets, tables, records (structs), reals (doubles), more * No second-class "primitive types" - * Not "object-oriented" (no classes, inheritance, or instance methods) + * Not "object-oriented" (no classes, inheritance, or instance + methods) * No exception catching - * No concurrency (no threads, monitors, semaphores, or synchronization) + * No concurrency (no threads, monitors, semaphores, or + synchronization) * Has co-expressions (coroutines) * Basic least-common-denominator system interface (a la ANSI C) - * Procedural graphics (event-driven paradigm available but not mandated) + * Procedural graphics (event-driven paradigm available but not + mandated) * Retained windows (programs are never called to repaint) * Simple GUI builder that can re-edit its generated code * Turtle graphics package @@ -113,15 +118,17 @@ Learning about Icon A4. What is the Icon program library? - The library is a collection of programs and procedures written in Icon. User - contributions are welcome and form a significant portion of the library. + The library is a collection of programs and procedures written in + Icon. User contributions form a significant portion of the library. - Library procedures effectively augment the built-in functions available to - an Icon program. A wide variety of procedures currently exists, and most - graphically-based programs are built around library procedures. + Library procedures effectively augment the built-in functions + available to an Icon program. A wide variety of procedures currently + exists, and most graphically-based programs are built around library + procedures. The core and graphics core modules are the most carefully + vetted. - The programs in the library range from simple demonstrations to handy tools - to complex graphical applications. + The programs in the library range from simple demonstrations to handy + tools to complex graphical applications. The library is a resource for both new and experienced programmers. In addition to their basic utility, its programs and procedures serve as @@ -138,32 +145,37 @@ Learning about Icon www.mitchellsoftwareengineering.com/icon * John Shipman's tutorial: www.nmt.edu/tcc/help/lang/icon + For the graphics facilities: + * The Icon Project Overview: + www.cs.arizona.edu/icon/ftp/doc/ipd281.pdf + A6. Where are some simple examples? - For some simple text-based programs, see any of those introductory documents - in the preceding question. For some simple graphics programs, see - www.cs.arizona.edu/icon/gb/progs/progs.htm. + For some simple text-based programs, see any of those introductory + documents in the preceding question. For some simple graphics + programs, see www.cs.arizona.edu/icon/gb/progs/progs.htm. - Many more examples, typically larger, are found in the Icon program library; - see the indexes of Basic Programs and Graphics Programs. + Many more examples, typically larger, are found in the Icon program + library; see the indexes of Basic Programs and Graphics Programs. A7. How about comprehensive documentation? - Two books define the Icon language. The core language is covered in The Icon - Programming Language (third edition), by Griswold and Griswold. Graphics - facilities are described in Graphics Programming in Icon by Griswold, - Jeffery, and Townsend. These books contain both tutorial and reference - material. + Two books define the Icon language. The core language is covered in + The Icon Programming Language (third edition), by Griswold and + Griswold. Graphics facilities are described in Graphics Programming in + Icon by Griswold, Jeffery, and Townsend. These books contain both + tutorial and reference material. - Icon's internals are detailed in The Implementation of the Icon Programming - Language by Griswold and Griswold. Although considerable changes have - occurred since Version 6, described in the book, the basic structure of Icon - remains the same. Two technical reports, IPD112 and IPD239, describe - subsequent changes. + Icon's internals are detailed in The Implementation of the Icon + Programming Language by Griswold and Griswold. Although considerable + changes have occurred since Version 6, described in the book, the + basic structure of Icon remains the same. Two technical reports, + IPD112 and IPD239, describe subsequent changes. - Printed copies of the Language and Graphics books are available from Jeffery - Systems (www.zianet.com/jeffery/books). All three books can be downloaded at - no charge from the Icon books page, www.cs.arizona.edu/icon/books.htm. + Printed copies of the Language and Graphics books are available from + Jeffery Systems (http://unicon.org/books/). All three books can be + downloaded at no charge from the Icon books page, + www.cs.arizona.edu/icon/books.htm. The Icon Programming Language Handbook, by Thomas W. Christopher, is available on the web at www.tools-of-computing.com/tc/CS/iconprog.pdf. @@ -171,101 +183,107 @@ Learning about Icon An on-line index to the Icon program library is found at www.cs.arizona.edu/icon/library/ipl.htm. - There is a large amount of additional information at the Icon web site, - www.cs.arizona.edu/icon. + There is a large amount of additional information at the Icon web + site, www.cs.arizona.edu/icon, including complete sets of back issues + of the Icon Newsletter and Icon Analyst. _________________________________________________________________ Implementations B1. What platforms support Icon? - Current implementations with graphics support are available for Unix - (including Linux) and Windows. The Unix implementation also runs on Darwin, - the Macintosh development environment, or the Cygwin environment under - Windows. Older versions of Icon are available for some other systems. An - alternative Java-based implementation for Unix, Jcon, is also available. + The current implementation of Icon is a Unix implementation. This + includes Linux, BSD, Solaris, Macintosh, and the Cygwin environment + under Windows. Version 9.5 of Icon has been tested on all these + platforms. - B2. How do I get started with Icon? + Older versions are available for Windows and some other systems. An + alternative Java-based implementation for Unix, Jcon, is also + available. - Version 9.4.3 of Icon for Unix can be downloaded from - www.cs.arizona.edu/icon/v943. Source and binary packages are available, each - with the complete Icon program library. + None of these environments includes a window-based development + environment. While Icon programs can open windows and use graphics, + programming is done using Unix editors and other tools from a command + shell. + + B2. How do I get started with Icon? - Version 9.3 of Icon for Windows is compatible at the source level with - version 9.4.3. It can be downloaded from www.cs.arizona.edu/icon/v93w.htm. - The Version 9.4.3 library can be obtained separately from - www.cs.arizona.edu/icon/v943. + The current version of Icon for Unix can be downloaded from + www.cs.arizona.edu/icon/current. Source and binary packages are + available, each with the complete Icon program library. - For older implementations, start at www.cs.arizona.edu/icon/implver.htm. - Jcon is at www.cs.arizona.edu/icon/jcon. + For older implementations, start at + www.cs.arizona.edu/icon/implver.htm. Jcon is at + www.cs.arizona.edu/icon/jcon. B3. Is there a Unicode version of Icon? - No. Icon is defined in terms of 8-bit characters, and changing this presents - several design challenges that would likely break existing programs. Also, - modifying the C implementation is probably infeasible, but a Unicode version - of Jcon might be possible. + No. Icon is defined in terms of 8-bit characters, and changing this + presents several design challenges that would likely break existing + programs. Also, modifying the C implementation is probably infeasible, + but a Unicode version of Jcon might be possible. B4. What happened to the compiler? - For a while, Unix distributions included both an interpreter and a compiler; - but the interpreter is is usually fast enough even for production work, and - most people found that using the compiler wasn't worth the extra compilation - time or the hassles involved. We no longer advertise the compiler or produce - binaries for it. It is still part of the source code distribution, and we - have not deliberately broken it, but we no longer support it and we cannot - offer help if problems arise. + For a while, Unix distributions included both an interpreter and a + compiler. The compiler was an interesting research project but it has + not been maintained and is no longer supported. The interpreter is + much easier to use and is generally quite fast enough, even for + production applications. _________________________________________________________________ Administration C1. What is the Icon Project? - The Icon Project is a name used by the group that distributes and supports - the Icon programming language. The project maintains the Icon web site at - www.cs.arizona.edu/icon. A non-commercial organization, the project is - supported by the Department of Computer Science at the University of - Arizona. + The Icon Project is a name used by the group that distributes and + supports the Icon programming language. The project maintains the Icon + web site at www.cs.arizona.edu/icon. A non-commercial organization, + the project is supported by the Department of Computer Science at the + University of Arizona. C2. How often is the on-line material updated? - New material is added when it's available. Established implementations - usually are updated only when there's a new version. This typically is every - year or two. The Icon program library is updated on a similar schedule. + The Icon implementation is now in maintenance mode, with new releases + produced only when necessary. This typically happens every few years + when a change in the Gnu tools cause the source to stop building. C3. Where did Icon come from? - Icon is the latest in a series of high-level programming languages designed - to facilitate programming tasks involving strings and structures. The - original language, SNOBOL, was developed at Bell Telephone Laboratories in - the early 1960s. SNOBOL evolved into SNOBOL4, which is still in use. - Subsequent languages were developed at the University of Arizona with - support from the National Science Foundation. Although it has similar - objectives and many similar capabilities, Icon bears little superficial - resemblance to SNOBOL4. - - Icon implementations were developed by faculty, staff, and students at the - University of Arizona, with significant contributions from volunteers around - the world. An Icon history by Ralph and Madge Griswold appears in the - preprints of the second History of Programming Languages Conference - (HOPL-II), ACM SIGPLAN Notices, March 1993 (Vol 28, No 3). + Icon is the latest in a series of high-level programming languages + designed to facilitate programming tasks involving strings and + structures. The original language, SNOBOL, was developed at Bell + Telephone Laboratories in the early 1960s. SNOBOL evolved into + SNOBOL4, which is still in use. Subsequent languages were developed at + the University of Arizona with support from the National Science + Foundation. Although it has similar objectives and many similar + capabilities, Icon bears little superficial resemblance to SNOBOL4. + + Icon implementations were developed by faculty, staff, and students at + the University of Arizona, with significant contributions from + volunteers around the world. An Icon history by Ralph and Madge + Griswold appears in the preprints of the second History of Programming + Languages Conference (HOPL-II), ACM SIGPLAN Notices, March 1993 (Vol + 28, No 3). The name Icon is not an acronym, nor does it stand for anything in - particular, although the word iconoclastic was mentioned when the name was - chosen. The name predates the now common use of icon to refer to small - images used in graphical user interfaces. This sometimes misleads people - into thinking that Icon is designed to create or manipulate icons, but - there's no good solution to that problem. + particular, although the word iconoclastic was mentioned when the name + was chosen. The name predates the now common use of icon to refer to + small images used in graphical user interfaces. This sometimes + misleads people into thinking that Icon is designed to create or + manipulate icons, but there's no good solution to that problem. C4. Where is Icon going? - We continue to use Icon on a daily basis, but no significant changes are - planned. We expect to support the Unix version for the forseeable future, - and to distribute ports to other systems as supplied by volunteers. + We continue to use Icon on a daily basis, but no significant changes + are planned. We expect to support the Unix version for the foreseeable + future, and to distribute ports to other systems as supplied by + volunteers. - The Unicon project is developing an object-oriented language based on Icon. - For more information, see unicon.sourceforge.net. An earlier object-oriented - extension to Icon, Idol, can be found in the Icon program library. + The Unicon project is developing an object-oriented language based on + Icon. For more information, see unicon.sourceforge.net. An earlier + object-oriented extension to Icon, Idol, can be found in the Icon + program library. _________________________________________________________________ Support @@ -277,61 +295,59 @@ Support D2. How do I get technical support? - The Icon Project is not a commercial organization, and its capacity for - providing technical support is limited. Please use the appropriate resource - when you need assistance: + The Icon Project is not a commercial organization, and its capacity + for providing technical support is limited. Please use the appropriate + resource when you need assistance: * For programming questions, submit a query to the Usenet newsgroup comp.lang.icon. * For porting assistance or Unix problems, contact icon-project@cs.arizona.edu. - * For problems with the Windows implementation, contact the implementor, - jeffery@cs.nmsu.edu. - * For general information and additional documentation, visit the Icon web - site: www.cs.arizona.edu/icon. + * For general information and additional documentation, visit the + Icon web site: www.cs.arizona.edu/icon. _________________________________________________________________ Programming E1. Why doesn't read() work with every? - every s := read() do {...} doesn't loop because read() produces a single - value and then fails if resumed. Other "consumer" procedures such as get() - and pop() work the same way. Use a while loop with these procedures, and - save every for use with generators such as !x or key(T). + every s := read() do {...} doesn't loop because read() produces a + single value and then fails if resumed. Other "consumer" procedures + such as get() and pop() work the same way. Use a while loop with these + procedures, and save every for use with generators such as !x or + key(T). E2. Why doesn't string invocation such as "foo"() work? - String invocation works if the procedure is present; the catch is that the - linker removes unreferenced procedures. To ensure a procedure's presence, - reference it in the main() procedure. A simple reference suffices, as in - refs := [foo, bar, baz]; it's not necessary to actually call it. + String invocation works if the procedure is present; the catch is that + the linker removes unreferenced procedures. To ensure a procedure's + presence, reference it in the main() procedure. A simple reference + suffices, as in refs := [foo, bar, baz]; it's not necessary to + actually call it. - (Why does the linker remove unreferenced procedures? Because this can save - huge amounts of memory for programs that use the library.) + (Why does the linker remove unreferenced procedures? To significantly + reduce the memory requirements of programs that use the library. There + was a time when this mattered.) E3. How can I call a C function? - You can't call an arbitrary C function, but if you're willing to write a - function to Icon's specifications, there are two approaches. Under Unix, - which provides loadfunc(), you can load one or more functions from a shared - library, and then treat them as if they had been written in Icon. Some - examples can be found in the cfuncs and packs/loadfuncs directories of the - Icon program library. The more cumbersome approach is to add code to the - Icon interpreter and rebuild it; some hooks are provided for this purpose. - Both approaches are discussed in Calling C Functions from Icon, - www.cs.arizona.edu/icon/docs/ipd240.htm. + You can't call an arbitrary C function, but you can load and call one + that is written to Icon's specifications. A tutorial appears in Icon + Analyst 36. Some examples can be found in the cfuncs and + packs/loadfuncs directories of the Icon program library. The Jcon implementation allows Icon programs to call Java code that is written to Jcon specifications. E4. Can I open a bidirectional pipe? - No, this is not possible. Although the concept is simple — write a line to a - program via a pipe, then read that program's output — it probably wouldn't - work. Most I/O libraries don't write anything to a pipe until they've filled - a buffer, and the most likely consequence would be a deadlock, with each - program waiting for the other to send more data. + No, this is not possible. Although the concept is simple -- write a + line to a program via a pipe, then read that program's output -- it + probably wouldn't work. Most I/O libraries don't write anything to a + pipe until they've filled a buffer, and the most likely consequence + would be a deadlock, with each program waiting for the other to send + more data. _________________________________________________________________ - This FAQ is edited by Gregg Townsend. It includes contributions from Ralph - Griswold, Cliff Hathaway, Clint Jeffery, Bob Alexander, and Todd Proebsting. + This FAQ is edited by Gregg Townsend. It includes contributions from + Ralph Griswold, Cliff Hathaway, Clint Jeffery, Bob Alexander, and Todd + Proebsting. diff --git a/doc/files.htm b/doc/files.htm index fd7fef0..83855b7 100644 --- a/doc/files.htm +++ b/doc/files.htm @@ -1,7 +1,7 @@ <!doctype html public "-//W3C//DTD HTML 4.01 Transitional//EN"> <HTML> <HEAD> - <TITLE>File Organization in Version 9.4 of Icon</TITLE> + <TITLE>File Organization in Versions Icon Installations</TITLE> <LINK REL="STYLESHEET" TYPE="text/css" HREF="istyle.css"> <LINK REL="SHORTCUT ICON" HREF="shortcut.gif"> </HEAD> @@ -10,15 +10,15 @@ <P><A HREF="http://www.cs.arizona.edu/icon/"> <IMG SRC="wwwcube.gif" ALT="[Icon home]" WIDTH=128 HEIGHT=144 BORDER=0 ALIGN=RIGHT> </A> -<H1> File Organization in Version 9.4 of Icon </H1> +<H1> File Organization in Icon Installations</H1> <P> Gregg M. Townsend <BR> <SMALL> Department of Computer Science </SMALL> <BR> <SMALL> The University of Arizona </SMALL> -<P> <SMALL> www.cs.arizona.edu/icon/v943/files.htm -<BR> Last updated November 8, 2005 </SMALL> -<!-- $Id: files.htm,v 1.17 2005/11/08 23:24:35 gmt Exp $ --> +<P> <SMALL> www.cs.arizona.edu/icon/v950/files.htm +<BR> Last updated November 16, 2009 </SMALL> +<!-- $Id: files.htm,v 1.19 2009/11/16 22:11:13 gmt Exp $ --> <H2> Introduction </H2> @@ -35,13 +35,13 @@ programs; yet the IPL had been treated as a separate product. A complete Icon system required two downloads and two installation efforts, with proper coordination. -<P> With Icon 9.4, the complete set of basic and graphics library +<P> Now, the complete set of basic and graphics library procedures is included with every binary Icon distribution. Also present are the associated <CODE>$include</CODE> files and a selected few programs from the library — notably VIB, the visual interface builder. -<P> Source distributions of Icon 9.4 include the full library, +<P> Source distributions of Icon include the full library, which also continues to be available separately. <H2> Installation directory structure </H2> @@ -64,9 +64,9 @@ and "ucode" (<CODE>.u1</CODE>/<CODE>.u2</CODE>) files of program library procedures. This directory is system independent. -<P> The <CODE>man</CODE> directory holds the Unix <CODE>man</CODE> page -for <CODE>icont</CODE>, and the <CODE>doc</CODE> directory holds -HTML (<CODE>.htm</CODE>) documentation files. +<P> The <CODE>man</CODE> directory holds the Unix <CODE>man</CODE> pages +for <CODE>icon</CODE> and <CODE>icont</CODE>, and the <CODE>doc</CODE> +directory holds HTML (<CODE>.htm</CODE>) documentation files. These directories are also system independent. <P> This structure is similar to that of binary distributions of Icon 9.3. @@ -108,7 +108,7 @@ The <CODE>iconx</CODE> location was configured by editing <CODE>patchstr</CODE> utility to edit the <CODE>icont</CODE> executable when installing a binary distribution. -<P> In version 9.4, <CODE>icont</CODE> deduces its own location, +<P> Now, <CODE>icont</CODE> deduces its own location, and from this it infers the location of <CODE>iconx</CODE> in the same directory. No configuration of <CODE>icont</CODE> is needed, and the correct @@ -128,7 +128,7 @@ path must be edited to match the installed location of <CODE>iconx</CODE>. The <CODE>ipatch</CODE> utility performed this task when installing binary distributions of Icon 9.3. -<P> Icon 9.4 implements a simple search in the shell script that +<P> Icon implements a simple search in the shell script that heads each generated Icon executable. The new header script searches for <CODE>iconx</CODE> in these places: @@ -173,7 +173,7 @@ loadable C functions without requiring explicit user action. distribution are ready for use without modification. The annoying and error-prone Setup step that was necessary with previous versions is no longer required. -With Icon 9.4, installation can be as simple as just unpacking the +Now, installation can be as simple as just unpacking the tar file and adding its <CODE>bin</CODE> directory to the search path. <P> <HR> diff --git a/doc/icon.txt b/doc/icon.txt index 4168ba5..a8b0c04 100644 --- a/doc/icon.txt +++ b/doc/icon.txt @@ -39,12 +39,14 @@ SEE ALSO icont(1), the full-featured interface supporting separate compilation, multiple source files, and other features. - The Icon Programming Language. Griswold and Griswold, Peer-to-Peer, - third edition, 1996. + The Icon Programming Language. + Griswold and Griswold, Peer-to-Peer, third edition, 1996. + http://www.cs.arizona.edu/icon/lb3.htm. - Graphics Programming in Icon. Griswold, Jeffery, and Townsend, Peer- - to-Peer, 1998. + Graphics Programming in Icon. + Griswold, Jeffery, and Townsend, Peer-to-Peer, 1998. + http://www.cs.arizona.edu/icon/gb/index.htm. - Version 9.4.3 of Icon. - http://www.cs.arizona.edu/icon/v943. + Version 9.5.0 of Icon. + http://www.cs.arizona.edu/icon/v950. diff --git a/doc/icont.txt b/doc/icont.txt index a5eb633..ae867bc 100644 --- a/doc/icont.txt +++ b/doc/icont.txt @@ -110,14 +110,16 @@ SEE ALSO icon(1), a simpler command interface for embedding Icon programs in scripts. - The Icon Programming Language. Griswold and Griswold, Peer-to-Peer, - third edition, 1996. + The Icon Programming Language. + Griswold and Griswold, Peer-to-Peer, third edition, 1996. + http://www.cs.arizona.edu/icon/lb3.htm. - Graphics Programming in Icon. Griswold, Jeffery, and Townsend, Peer- - to-Peer, 1998. + Graphics Programming in Icon. + Griswold, Jeffery, and Townsend, Peer-to-Peer, 1998. + http://www.cs.arizona.edu/icon/gb/index.htm. - Version 9.4.3 of Icon. - http://www.cs.arizona.edu/icon/v943. + Version 9.5.0 of Icon. + http://www.cs.arizona.edu/icon/v950. CAVEATS Icon executables are not self-sufficient, but require the iconx inter- diff --git a/doc/index.htm b/doc/index.htm index 0c62d4e..b2806bc 100644 --- a/doc/index.htm +++ b/doc/index.htm @@ -13,15 +13,18 @@ ALT="[Icon home]" WIDTH=128 HEIGHT=144 BORDER=0 ALIGN=RIGHT> </A> <H1>Icon Documentation</H1> <P> <A HREF=docguide.htm> Documentation guide </A> +<P> The <A href="icon.txt"><CODE>icon</CODE></A> + and <A href="icont.txt"><CODE>icont</CODE></A> commands <P> <A HREF=relnotes.htm> Release notes </A> +<P> <A HREF=macintosh.htm> Icon on Macintosh </A> +<P> <A HREF=cygwin.htm> Icon on Cygwin </A> +<P> <A HREF=faq.htm> Frequently asked questions </A> <P> <A HREF=install.htm>Installation instructions (for binary releases) </A> <P> <A HREF=build.htm> Build instructions (for source releases) </A> -<P> <A HREF=port.htm> Porting instructions </A> <P> <A HREF=files.htm> File organization </A> -<P> <A HREF=macintosh.htm> Icon on Macintosh </A> -<P> <A HREF=cygwin.htm> Icon on Cygwin </A> -<P> <A HREF=faq.htm> Frequently asked questions about Icon </A> - +<P> <A HREF=port.htm> Porting instructions </A> +<P> <A HREF=cfuncs.htm> Loading C functions dynamically</A> +<P> <A HREF=extlvals.htm> External values</A> <P> <HR> diff --git a/doc/install.htm b/doc/install.htm index 900227b..4b6c282 100644 --- a/doc/install.htm +++ b/doc/install.htm @@ -1,7 +1,7 @@ <!doctype html public "-//W3C//DTD HTML 4.01 Transitional//EN"> <HTML> <HEAD> - <TITLE>Installing Binaries of Version 9.4 of Icon</TITLE> + <TITLE>Installing Binaries of Version 9.5 of Icon</TITLE> <LINK REL="STYLESHEET" TYPE="text/css" HREF="istyle.css"> <LINK REL="SHORTCUT ICON" HREF="shortcut.gif"> </HEAD> @@ -10,20 +10,20 @@ <P><A HREF="http://www.cs.arizona.edu/icon/"> <IMG SRC="wwwcube.gif" ALT="[Icon home]" WIDTH=128 HEIGHT=144 BORDER=0 ALIGN=RIGHT> </A> -<H1>Installing Binaries of Version 9.4 of Icon</H1> +<H1>Installing Binaries of Version 9.5 of Icon</H1> <P> Gregg M. Townsend <BR> <SMALL> Department of Computer Science </SMALL> <BR> <SMALL> The University of Arizona </SMALL> -<P> <SMALL> www.cs.arizona.edu/icon/v943/install.htm -<BR> Last updated November 8, 2005 </SMALL> -<!-- $Id: install.htm,v 1.17 2005/11/08 23:24:35 gmt Exp $ --> +<P> <SMALL> www.cs.arizona.edu/icon/v950/install.htm +<BR> Last updated November 8, 2009 </SMALL> +<!-- $Id: install.htm,v 1.18 2009/11/08 21:53:08 gmt Exp $ --> <P> <P> These instructions explain how to install Unix binaries of -<A HREF=relnotes.htm>Version 9.4 of Icon</A>. +<A HREF=relnotes.htm>Version 9.5 of Icon</A>. For instructions on building an Icon source package, see <A HREF=build.htm>Building Icon from Source</A>. diff --git a/doc/istyle.css b/doc/istyle.css index 820fd71..3e183cc 100644 --- a/doc/istyle.css +++ b/doc/istyle.css @@ -21,6 +21,7 @@ LI { margin-top: 0.2em; } TH, TD { padding-left: 0.4em; padding-right: 0.4em; } TH, TD { vertical-align: top; text-align: left; } +TH { font-weight: normal; font-style: italic; } A:link { background: white; color: #06C; } A:visited { background: white; color: #036; } diff --git a/doc/macintosh.htm b/doc/macintosh.htm index a6b39de..7cdcbc5 100644 --- a/doc/macintosh.htm +++ b/doc/macintosh.htm @@ -18,9 +18,9 @@ <SMALL>Department of Computer Science</SMALL><BR> <SMALL>The University of Arizona</SMALL></P> - <P><SMALL>www.cs.arizona.edu/icon/v943/macintosh.htm<BR> - Last updated November 9, 2005</SMALL> - <!-- $Id: macintosh.htm,v 1.1 2005/11/09 18:03:59 gmt Exp $ --></P> + <P><SMALL>www.cs.arizona.edu/icon/v950/macintosh.htm<BR> + Last updated November 19, 2009</SMALL> + <!-- $Id: macintosh.htm,v 1.5 2009/11/19 18:49:31 gmt Exp $ --></P> <H2>Introduction</H2> @@ -39,33 +39,32 @@ <CITE>cc</CITE> command, supports multiple files, separate compilation, and other features.</P> - <H2>Graphics</H2> + <H2>Co-Expressions</H2> + + <P> + Because MacOS does not implement anonymous semaphores, + each co-expression creates an open file. + Programs with hundreds of active co-expressions may + abort with a <CODE>cannot create semaphore</CODE> system error. + The open file limit can be raised from the typical default of 256 + using a <CODE>limit descriptors <I>n</I></CODE> or + <CODE>ulimit -nS <I>n</I></CODE> command, depending on the shell. - <P>For graphics, Icon uses the X Window System, generally called - <A href="http://www.apple.com/macosx/features/x11/">X11</A> in - Macintosh documentation. X11 is not normally installed as part of - OS X; it must be selected as part of a custom installation. - Alternatively, it can be - <A HREF="http://www.apple.com/support/downloads/x11formacosx.html"> - downloaded</A> from Apple.</P> - <P>The X window system does not start automatically. To run an - Icon graphics program, you must first start the X11 application - and leave it running. The environment variable DISPLAY must be - set in the shell that runs an Icon graphics program. For - example:</P> + <H2>Graphics</H2> - <BLOCKQUOTE> - <P><CODE>setenv DISPLAY :0.0</CODE></P> - </BLOCKQUOTE> + <P>For graphics, Icon uses the X Window System, generally called X11 in + Macintosh documentation. + Beginning with Mac OS 10.5 (Leopard), X11 starts automatically + when needed, and no advance preparations are needed. + An X11 icon appears in the dock when an Icon graphics program + is run and persists innocuously afterward. <H2>Building Icon</H2> <P>Building Icon from source requires the <A href= - "http://www.apple.com/macosx/features/xcode/">Xcode</A> toolbox. - This comes in an extra folder on the OS X installation disc. - When installing XCode, be sure to select a custom - installation and add X11 to the default set.</P> + "http://developer.apple.com/tools/xcode/">Xcode</A> toolbox, + which comes on the OS X installation disk.</P> <P>Icon is built in a Terminal window. The process is the same as on other platforms and uses the configuration named diff --git a/doc/port.htm b/doc/port.htm index 5be8473..f05684b 100644 --- a/doc/port.htm +++ b/doc/port.htm @@ -16,9 +16,9 @@ ALT="[Icon home]" WIDTH=128 HEIGHT=144 BORDER=0 ALIGN=RIGHT> </A> <BR> <SMALL> Department of Computer Science </SMALL> <BR> <SMALL> The University of Arizona </SMALL> -<P> <SMALL> www.cs.arizona.edu/icon/v943/port.htm -<BR> Last updated November 8, 2005 </SMALL> -<!-- $Id: port.htm,v 1.5 2005/11/08 23:24:35 gmt Exp $ --> +<P> <SMALL> www.cs.arizona.edu/icon/v950/port.htm +<BR> Last updated March 25, 2010 </SMALL> +<!-- $Id: port.htm,v 1.9 2010/03/25 23:33:10 gmt Exp $ --> <H2> Introduction </H2> @@ -47,7 +47,7 @@ although they are not part of the 1992 standard. <H3>C Compiler</H3> -Icon requires a production-quality compiler supporting ANSI C (X3.159-1989). +Icon requires a production-quality compiler supporting C99 (ISO/IEC 9899:1999). <EM>Production quality</EM> implies correctness, robustness, and the ability to handle large files and complicated expressions. @@ -71,8 +71,6 @@ In addition to the standard C library, Icon uses the library functions specified by POSIX.1 (IEEE 1993.1-1996). In particular, Icon uses <DFN>POSIX threads</DFN> and <DFN>semaphores</DFN> to implement context switching for co-expressions. -This eliminates the need for specialized assembly-language code, -some of which can still be seen in older configurations. @@ -141,7 +139,7 @@ The parameters set here are: <DT><CODE>CC</CODE> <DD>The command name for the C compiler. Typical values are - <CODE>cc</CODE>, <CODE>gcc</CODE>, or <CODE>c89</CODE>. + <CODE>cc</CODE>, <CODE>gcc</CODE>, or <CODE>c99</CODE>. <DT><CODE>CFLAGS</CODE> <DD>C compiler flags. A path specification for the X11 libraries diff --git a/doc/relnotes.htm b/doc/relnotes.htm index ae6bf1f..9466806 100644 --- a/doc/relnotes.htm +++ b/doc/relnotes.htm @@ -1,7 +1,7 @@ <!doctype html public "-//W3C//DTD HTML 4.01 Transitional//EN"> <HTML> <HEAD> - <TITLE>Release Notes for Version 9.4.3 of Icon</TITLE> + <TITLE>Release Notes for Version 9.5 of Icon</TITLE> <LINK REL="STYLESHEET" TYPE="text/css" HREF="istyle.css"> <LINK REL="SHORTCUT ICON" HREF="shortcut.gif"> </HEAD> @@ -10,78 +10,118 @@ <P><A HREF="http://www.cs.arizona.edu/icon/"> <IMG SRC="wwwcube.gif" ALT="[Icon home]" WIDTH=128 HEIGHT=144 BORDER=0 ALIGN=RIGHT> </A> -<H1> Release Notes for Version 9.4.3 of Icon </H1> +<H1> Release Notes for Version 9.5 of Icon </H1> <P> Gregg M. Townsend <BR> <SMALL> Department of Computer Science </SMALL> <BR> <SMALL> The University of Arizona </SMALL> -<P> <SMALL> www.cs.arizona.edu/icon/v943/relnotes.htm -<BR> Last updated November 10, 2005 </SMALL> -<!-- $Id: relnotes.htm,v 1.49 2005/11/10 23:02:06 gmt Exp $ --> +<P> <SMALL> www.cs.arizona.edu/icon/v950/relnotes.htm +<BR> Last updated April 12, 2010</SMALL> +<!-- $Id: relnotes.htm,v 1.74 2010/04/12 20:39:24 gmt Exp $ --> <H2> Introduction </H2> -<P> Version 9.4.3 of Icon is a minor update to version 9.4.2 of Icon. -It incorporates configuration, documentation, and library updates. +<P> Version 9.5.0 of Icon is an update of version 9.4.3 of Icon. +It incorporates configuration, documentation, and library changes. Some minor bugs have been fixed. +Support has been added for "external values" created by +user C functions. -<P> The Icon language is unchanged, and this Unix implementation -remains compatible at the source level with Icon 9.3 for Windows. - -<H2> Changes in version 9.4.3 </H2> +<H2> Changes in version 9.5 </H2> <P> Notable changes in this latest version are listed here. Some code cleanup work and documentation editing has also been done. -<H3> Configurations </H3> +<H3> External Values </H3> + +<P> External code incorporated by <CODE>loadfunc()</CODE> can now create +and return to Icon code opaque values that can be stored and passed +on subsequent calls. +This is similar to a feature of the early Macintosh ProIcon implementation. +See <A HREF=extlvals.htm>External Values</A> for more information. + +<H3> Build Environment </H3> + +<P> This version of Icon is the first to deliberately move beyond the +1989 C standard and make use of features of the 1999 C standard, +specifically the "struct hack". +Consequently, a C99 (or newer) compiler is now required to build Icon. + +<H3> Cygwin Configuration </H3> + +<P> The <CODE>cygwin</CODE> configuration has improved, partially through +removal of unneeded special cases now that Cygwin better approximates Unix. +External functions can now be loaded using <CODE>loadfunc()</CODE>. + +<P> In addition to the <CODE>cygwin</CODE> configuration, which uses +Windows graphics, there is now a new <CODE>xcygwin</CODE> configuration +that uses the X window system. -<P> The system-specific Icon configurations have been reorganized and renamed; -new names focus on operating systems rather than CPU architectures. -The several BSD configurations have been merged into one. +<H3> Implementation Cleanup</H3> -<P> The <CODE>macintosh</CODE> configuration now supports the -<CODE>loadfunc</CODE> function. This configuration has also been -revised to anticipate Apple's announced migration to the x86 architecture. +<P> Large amounts of conditionalized dead code, including the old Icon +compiler, have been removed from the source code. -<P> A new <A HREF=port.htm>porting guide</A> has been written, and a new -<CODE>posix</CODE> configuration has been added -as a starting point in constructing new ports. +<P> All platforms now use POSIX threads for context switching instead of +system- and processor-dependent assembly language code. + +<H3> Minor Fixes </H3> + +<P> The <CODE>loadfunc()</CODE> implementation now specifies to the system +that C globals are to be shared with and among loaded functions. + +<P> The command <CODE>icon nonexistent.icn</CODE> no longer leaves debris +in the /tmp directory. + +<P> The maximum length of a file name has been increased from 256 to 512 +characters. + +<P> Table copying in the Sparc (Solaris) configuration was fixed by +coding a workaround to avoid a GCC 4.2.2 struct assignment bug. <H3> Library changes </H3> -<P> As usual, several files in the Icon program library have been -added or edited. The core library files, however, remain stable. +<P> As usual, some files in the Icon program library have been +added or edited, but the core library files remain stable. Notable changes include: <PRE> -procs/dijkstra new procedures implement Dijkstra's control structures -procs/html add procedure for canonicalization of paths -procs/matrix2 new procedures for matrix manipulation -procs/nestlist new procedures for representing nested lists as strings -procs/printf add %e format and fix a rounding problem - -progs/noise new program for producing a random bitstream -progs/unclog improve logic for combining adjacent entries - -gprogs/dlgvu improve coverage map; allow altitude in GPS data -gprogs/gallery faster thumbnail loading for JPEG images -gprogs/img many new features -gprogs/sier better color choices -gprogs/trkvu accept GPS track logs with altitude as the last field +procs/echo New procedure for interpolating variables in strings. +procs/printf Rewrite parts to fix several bugs, and add test. +procs/random Improve thoroughness of randomize(). + +progs/diffsum Handle output of "cvs diff". +progs/unclog Handle CVS branches; fix indentation. +progs/weblinks Add option to sort output by referencing page. + +gprogs/breakout Make the ball large enough to see. +gprogs/gallery Treat -wnnn and -hnnn options as *minimums*. +gprogs/gallery Handle spaces embedded in JPEG filenames. +gprogs/kaleid Add delay to prevent runaway on fast CPUs. +gprogs/spider Add shortcuts, opt-in logging, congratulatory display. +gprogs/trkvu Limit file legend to onscreen files. +gprogs/tron New video game inspired by Tron. + +packs/loadfuncpp Add C++ interface package. +packs/icondb Add MySQL interface package. + +gpacks/weaving Add "halftone" weaving program htweav.icn. </PRE> -The undocumented <CODE>save</CODE> function, which only worked -on a few platforms, has been removed. +<H3> Documentation Additions </H3> + +<P> Two new documentation pages, <A HREF="cfuncs.htm">Loading C functions</A> +and <A HREF="extlvals.htm">External Values</A>, have been added. <H2> Earlier feature additions </H2> -<P> These features appeared in earlier releases of Icon that followed -publication of the Icon books. +<P> These features appeared in earlier releases of Icon +but subsequent to publication of the Icon books. <H3> Millions of colors </H3> <SMALL> (new with version 9.4.2 of Icon) </SMALL> @@ -102,7 +142,7 @@ which in another form allows a small Icon program to be embedded within a shell script. See the <A HREF="icon.txt">man page</A> for details. The traditional <A HREF="icont.txt"><CODE>icont</CODE></A> command -remains available for less specialized purposes. +remains available when more flexibility is needed. <H3> Path searching </H3> <SMALL> (new with version 9.4.0 of Icon) </SMALL> @@ -116,7 +156,7 @@ The Icon translator and linker search these paths when looking for <P> The Icon program library is now searched automatically, but <CODE>LPATH</CODE> and <CODE>IPATH</CODE> can still be set to control the search order. -For version 9.4, the effective path in each case is: +The effective path in each case is: <OL> <LI> The current directory <LI> Any directories named by the environment variable @@ -201,13 +241,15 @@ for an overview of the available Icon documentation. <H2> Acknowledgments </H2> -<P> -Arthur Eschenlauer contributed the <CODE>matrix2</CODE> -and <CODE>nestlist</CODE> libraries. -Frank Lhota contributed the <CODE>dijkstra</CODE> library. -Nolan Clayton contributed revisions to the <CODE>img</CODE> program. -Michael Glass contributed revisions to the <CODE>printf</CODE> procedure. -Chris Tenaglia and Andreas Almroth contributed configuration files. +<P> Carl Sturtivant inspired and participated in the development +of external values. He also contributed the <CODE>loadfuncpp</CODE> +and <CODE>icondb</CODE> packages. +Eduardo Ochs contributed the <CODE>tron</CODE> game. +Charles L. Hethcoat III contributed the <CODE>echo</CODE> procedure. +Carl Sturtivant and Steve Waldo supplied numerous Cygwin improvements. +Cheyenne Wills improved the flexibility of the configuration process. +Clint Jeffery fixed an ancient linking bug. +Robert Shiplett and Jonathan Kaye helped with testing. <P> <HR> diff --git a/ipl/BuildExe b/ipl/BuildExe index 8082b9c..05800d9 100755 --- a/ipl/BuildExe +++ b/ipl/BuildExe @@ -2,7 +2,7 @@ # # BuildExe -- build executables in ./iexe # -# Includes programs from pack directories, but excludes mprogs. +# Includes programs from pack directories. # Assumes that ../bin and ../lib have been built. set -x diff --git a/ipl/CheckAll b/ipl/CheckAll index 0a3da38..621610b 100755 --- a/ipl/CheckAll +++ b/ipl/CheckAll @@ -49,7 +49,6 @@ done (echo cfuncs:; cd cfuncs; LPATH= make -s cfunc.u2) (echo procs:; cd procs; LPATH="../incl" icont -usc *icn) (echo gprocs:; cd gprocs; LPATH="../incl ../gincl" icont -usc *icn) -# (echo mprocs:; cd mprocs; LPATH="../incl ../gincl ../mincl" icont -usc *icn) # Check for undeclared identifiers or insufficient links in the core modules. @@ -88,18 +87,19 @@ export LPATH="../incl ../gincl" export IPATH="../procs ../cfuncs ../gprocs" (echo gprogs:; cd gprogs; for f in *.icn; do compile $f; done) -# Skip mprogs, which requires a specially build MT-Icon version -# export LPATH="../incl ../gincl ../mincl" -# export IPATH="../procs ../cfuncs ../gprocs ../mprocs" -# (echo mprogs:; cd mprogs; for f in *.icn; do compile $f; done) - - -# Test-build all the packages +# Test-build most of the packages (skipping GNU-only packs) # Allow use of graphics within packs, because one loadfunc example needs it export LPATH="../../incl ../../gincl" export IPATH="../../cfuncs ../../procs ../../gprocs" for d in *packs/[a-z]*; do - echo $d: - (cd $d; make -s Clean; make -s) + case $d in + packs/icondb | packs/loadfuncpp) + echo $d skipped + ;; + *) + echo $d: + (cd $d; make -s Clean; make -s) + ;; + esac done diff --git a/ipl/Makefile b/ipl/Makefile index a438946..fc01edf 100644 --- a/ipl/Makefile +++ b/ipl/Makefile @@ -65,7 +65,6 @@ ZipFiles: Ilib rm -rf ilib *.zip zip -qrX9 bipl.zip docs incl procs progs packs data cfuncs -x '*/CVS/*' zip -qrX9 gipl.zip gdocs gincl gprocs gprogs gpacks gdata -x '*/CVS/*' - zip -qrX9 mipl.zip mincl mprocs mprogs -x '*/CVS/*' mkdir ilib cp ../lib/*.* ilib zip -qrX9 ilib.zip ilib @@ -75,7 +74,8 @@ ZipFiles: Ilib # Clean up. Clean Pure: - -rm -rf ilib iexe *.zip */*.u[12] */*.zip */*.so + -rm -rf ilib iexe *.zip */*.u[12] */*.zip */*.so *packs/*/*.exe -rm -f xx `find *procs *progs -type f -perm -100 -print` for d in cfuncs *packs/[abcdefghijklmnopqrstuvwxyz]*; do \ - (cd $$d; $(MAKE) Clean); done + echo "+ cd ipl/$$d"; \ + (cd $$d; $(MAKE) Clean 2>/dev/null) || echo "[not cleaned]"; done @@ -1,9 +1,6 @@ -This is Version 9.4.3 of the Icon Program Library. +This is Version 9.5.0 of the Icon Program Library. For on-line documentation, see - http://www.cs.arizona.edu/icon/v943/library/ipl.htm + http://www.cs.arizona.edu/icon/v950/library/ipl.htm Unix users should generally not try to build the library separately, but -instead should install Icon 9.4.3 as a whole, which includes the library. - -The MT-Icon portions of the library (the m*) directories are for use with -specially configured versions of Icon, for which no support is provided. +instead should install Icon 9.5.0 as a whole, which includes the library. diff --git a/ipl/cfuncs/Makefile b/ipl/cfuncs/Makefile index d8b1ba2..802e85b 100644 --- a/ipl/cfuncs/Makefile +++ b/ipl/cfuncs/Makefile @@ -14,7 +14,7 @@ FUNCLIB = libcfunc.so .SUFFIXES: .c .o .c.o: ; $(CC) $(CFLAGS) $(CFDYN) -c $< -FUNCS = bitcount.o files.o fpoll.o internal.o lgconv.o osf.o \ +FUNCS = bitcount.o external.o files.o fpoll.o internal.o lgconv.o osf.o \ pack.o ppm.o process.o tconnect.o CSRC = $(FUNCS:.o=.c) @@ -25,7 +25,8 @@ default: cfunc.u2 $(FUNCLIB) # library $(FUNCLIB): $(FUNCS) mklib.sh - CC="$(CC)" CFLAGS="$(CFLAGS)" sh mklib.sh $(FUNCLIB) $(FUNCS) + CC="$(CC)" CFLAGS="$(CFLAGS)" BIN="../../bin" \ + sh mklib.sh $(FUNCLIB) $(FUNCS) $(FUNCS): icall.h diff --git a/ipl/cfuncs/external.c b/ipl/cfuncs/external.c new file mode 100644 index 0000000..afb96fa --- /dev/null +++ b/ipl/cfuncs/external.c @@ -0,0 +1,154 @@ +/* +############################################################################ +# +# File: external.c +# +# Subject: Functions to demonstrate Icon external values +# +# Author: Gregg M. Townsend +# +# Date: October 29, 2009 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# These functions demonstrate the use of external values. +# +# extxmin() creates a minimal external type +# extxstr(s) creates an external hold a string and trivial checksum +# extxreal(r) creates a fully customized external type holding a real value +# +############################################################################ +# +# Requires: Dynamic loading +# +############################################################################ +*/ + +#include <string.h> +#include "icall.h" + +/* + * minimal external type with no parameters + */ +int extxmin(int argc, descriptor argv[]) /*: create minimal external value */ + { + RetExternal(alcexternal(0, 0, 0)); + } + +/* + * custom external holding a string and a trivial checksum + */ + +/* custom external data block extends the standard block */ +typedef struct sblock { + externalblock eb; + unsigned short cksum; + char string[]; + } sblock; + +/* type name returns "xstr" */ +static int sname(int argc, descriptor argv[]) { + RetConstStringN("xstr", 4); + } + +/* image returns "xstr_N(cksum:string)" with no special string escapes */ +static int simage(int argc, descriptor argv[]) { + sblock *b = (sblock*)ExternalBlock(argv[1]); + char buffer[1000]; /* not robust against huge strings */ + RetStringN(buffer, + sprintf(buffer, "xstr_%ld(%05d:%s)", b->eb.id, b->cksum, b->string)); + } + +/* list of custom functions for constructor */ +static funclist sfuncs = { + NULL, /* cmp */ + NULL, /* copy */ + sname, /* name */ + simage, /* image */ + }; + +/* finally, the exported constructor function, extxstr(s) */ +int extxstr(int argc, descriptor argv[]) /*: create string-valued external */ + { + sblock *new; + char *p; + int slen; + + ArgString(1); + slen = StringLen(argv[1]); + new = (sblock *)alcexternal(sizeof(sblock) + slen + 1, &sfuncs, 0); + memcpy(new->string, StringAddr(argv[1]), slen); + new->string[slen] = '\0'; + int cksum = 0; + for (p = new->string; *p; p++) + cksum = 37 * cksum + (unsigned char) *p; + new->cksum = cksum; + RetExternal((externalblock*)new); + } + + +/* + * custom real-valued external with lots of trimmings + */ + +/* custom external data block extends the standard block */ +typedef struct rblock { + externalblock eb; + float value; + } rblock; + +/* comparison function for sorting */ +static int rcmp(int argc, descriptor argv[]) { + rblock *eb1 = (rblock*)ExternalBlock(argv[1]); + rblock *eb2 = (rblock*)ExternalBlock(argv[2]); + if (eb1->value < eb2->value) RetInteger(-1); + if (eb1->value > eb2->value) RetInteger(+1); + if (eb1->eb.id < eb2->eb.id) RetInteger(-1); + if (eb1->eb.id > eb2->eb.id) RetInteger(+1); + RetInteger(0); + } + +/* copy function duplicates block, getting new serial number */ +static int rcopy(int argc, descriptor argv[]) { + externalblock *b = ExternalBlock(argv[1]); + rblock *old = (rblock*)b; + rblock *new = (rblock *)alcexternal(sizeof(rblock), b->funcs, 0); + new->value = old->value; + RetExternal((externalblock*)new); + } + +/* type name returns "xreal" */ +static int rname(int argc, descriptor argv[]) { + RetConstStringN("xreal", 5); + } + +/* image returns "xreal_N(V)" */ +static int rimage(int argc, descriptor argv[]) { + rblock *b = (rblock*)ExternalBlock(argv[1]); + char buffer[100]; + RetStringN(buffer, + sprintf(buffer, "xreal_%ld(%.1f)", b->eb.id, b->value)); + } + +/* list of custom functions for constructor */ +static funclist rfuncs = { + rcmp, /* cmp */ + rcopy, /* copy */ + rname, /* name */ + rimage, /* image */ + }; + +/* finally, the exported constructor function, extxreal(r) */ +int extxreal(int argc, descriptor argv[]) /*: create real-valued external */ + { + rblock *new; + + ArgReal(1); + float v = RealVal(argv[1]); + new = (rblock *)alcexternal(sizeof(rblock), &rfuncs, &v); + RetExternal((externalblock*)new); + } diff --git a/ipl/cfuncs/fpoll.c b/ipl/cfuncs/fpoll.c index f209e0d..9230e18 100644 --- a/ipl/cfuncs/fpoll.c +++ b/ipl/cfuncs/fpoll.c @@ -7,7 +7,7 @@ # # Author: Gregg M. Townsend # -# Date: November 27, 2001 +# Date: October 27, 2009 # ############################################################################ # @@ -29,6 +29,7 @@ */ #include <stdio.h> +#include <string.h> /* for memset call from FD_ZERO (solaris gcc) */ #include <sys/types.h> #include <sys/time.h> diff --git a/ipl/cfuncs/icall.h b/ipl/cfuncs/icall.h index 2718dfa..14089a5 100644 --- a/ipl/cfuncs/icall.h +++ b/ipl/cfuncs/icall.h @@ -7,7 +7,7 @@ # # Author: Gregg M. Townsend # -# Date: November 17, 2004 +# Date: October 29, 2009 # ############################################################################ # @@ -15,7 +15,7 @@ # ############################################################################ # -# Contributor: Kostas Oikonomou +# Contributors: Kostas Oikonomou, Carl Sturtivant # ############################################################################ # @@ -38,14 +38,14 @@ # ############################################################################ # -# IconType(d) returns one of the characters {cfinprsCILRST} indicating -# the type of a value according to the key on page 247 of the Red Book -# or page 273 of the Blue Book (The Icon Programming Language). +# IconType(d) returns one of the characters {cfinprsCEILRST} indicating +# the type of a value based on the key on page 273 of the Blue Book (The +# Icon Programming Language). The character E indicates external data; # The character I indicates a large (multiprecision) integer. # -# Only a few of these types (i, r, f, s) are easily manipulated in C. +# Only a few of these types (i, r, f, s, E) are easily manipulated in C. # Given that the type has been verified, the following macros return -# the value of a descriptor in C terms: +# a value from a descriptor in C terms: # # IntegerVal(d) value of a integer (type 'i') as a C long # RealVal(d) value of a real (type 'r') as a C double @@ -58,6 +58,7 @@ # StringLen(d) length of string # # ListLen(d) length of list +# ExternalBlock(d) address of heap block for external data # # These macros check the type of an argument, converting if necessary, # and returning an error code if the argument is wrong: @@ -66,6 +67,7 @@ # ArgReal(i) check that argv[i] is a real number # ArgString(i) check that argv[i] is a string # ArgList(i) check that argv[i] is a list +# ArgExternal(i,f) check that argv[i] is an external w/ funcblock f # # Caveats: # Allocation failure is not detected. @@ -80,6 +82,7 @@ # RetInteger(i) return integer value i # RetReal(v) return real value v # RetFile(fp,status,name) return (newly opened) file +# RetExternal(e) return block at addr e made by alcexternal() # RetString(s) return null-terminated string s # RetStringN(s, n) return string s whose length is n # RetAlcString(s, n) return already-allocated string @@ -121,11 +124,13 @@ #define T_Integer 1 /* integer */ #define T_Real 3 /* real number */ #define T_File 5 /* file, including window */ +#define T_External 19 /* externally defined data */ #define D_Null (T_Null | D_Typecode) #define D_Integer (T_Integer | D_Typecode) #define D_Real (T_Real | D_Typecode | F_Ptr) #define D_File (T_File | D_Typecode | F_Ptr) +#define D_External (T_External | D_Typecode | F_Ptr) #define Fs_Read 0001 /* file open for reading */ #define Fs_Write 0002 /* file open for writing */ @@ -139,10 +144,25 @@ typedef struct { word title; double rval; } realblock; typedef struct { word title; FILE *fp; word stat; descriptor fname; } fileblock; typedef struct { word title, size, id; void *head, *tail; } listblock; +typedef struct externalblock { + word title, size, id; + struct funclist *funcs; + word data[]; +} externalblock; + +typedef struct funclist { + int (*extlcmp) (int argc, descriptor argv[]); + int (*extlcopy) (int argc, descriptor argv[]); + int (*extlname) (int argc, descriptor argv[]); + int (*extlimage)(int argc, descriptor argv[]); +} funclist; + char *alcstr(char *s, word len); realblock *alcreal(double v); fileblock *alcfile(FILE *fp, int stat, descriptor *name); +externalblock *alcexternal(long nbytes, funclist *f, void *data); + int cnv_c_str(descriptor *s, descriptor *d); int cnv_int(descriptor *s, descriptor *d); int cnv_real(descriptor *s, descriptor *d); @@ -152,7 +172,7 @@ double getdbl(descriptor *d); extern descriptor nulldesc; /* null descriptor */ -#define IconType(d) ((d).dword>=0 ? 's' : "niIrcfpRL.S.T.....C"[(d).dword&31]) +#define IconType(d) ((d).dword>=0 ? 's' : "niIrcfpRL.S.T.....CE"[(d).dword&31]) #define IntegerVal(d) ((d).vword) @@ -170,6 +190,8 @@ extern descriptor nulldesc; /* null descriptor */ #define ListLen(d) (((listblock *)((d).vword))->size) +#define ExternalBlock(d) ((externalblock *)(d).vword) + #define ArgInteger(i) do { if (argc < (i)) Error(101); \ if (!cnv_int(&argv[i],&argv[i])) ArgError(i,101); } while (0) @@ -184,6 +206,12 @@ if (!cnv_str(&argv[i],&argv[i])) ArgError(i,103); } while (0) do {if (argc < (i)) Error(108); \ if (IconType(argv[i]) != 'L') ArgError(i,108); } while(0) +#define ArgExternal(i,f) \ +do {if (argc < (i)) Error(131); \ +if (IconType(argv[i]) != 'E') ArgError(i,131); \ +if (ExternalBlock(argv[i])->funclist != (f)) ArgError(i,132); \ +} while(0) + #define RetArg(i) return (argv[0] = argv[i], 0) @@ -198,6 +226,8 @@ do { descriptor dd; dd.vword = (word)alcstr(name, dd.dword = strlen(name)); \ argv->dword = D_File; argv->vword = (word)alcfile(fp, stat, &dd); \ return 0; } while (0) +#define RetExternal(e) return (argv->dword=D_External, argv->vword=(word)(e), 0) + #define RetString(s) \ do { word n = strlen(s); \ argv->dword = n; argv->vword = (word)alcstr(s,n); return 0; } while (0) diff --git a/ipl/cfuncs/mklib.sh b/ipl/cfuncs/mklib.sh index 533af0b..4caeca4 100755 --- a/ipl/cfuncs/mklib.sh +++ b/ipl/cfuncs/mklib.sh @@ -3,6 +3,7 @@ # mklib libname.so obj.o ... CC=${CC-cc} +BIN=${BIN-../../bin} LIBNAME=${1?"usage: $0 libname obj..."} shift @@ -11,9 +12,16 @@ SYS=`uname -s` set -x case "$SYS" in Linux*|*BSD*|GNU*) - gcc -shared -o $LIBNAME -fPIC "$@";; + $CC -shared -o $LIBNAME -fPIC "$@";; + CYGWIN*) + # move the win32 import library for iconx.exe callbacks + # created when iconx.exe was built + if [ -e $BIN/../src/runtime/iconx.a ]; then + mv $BIN/../src/runtime/iconx.a $BIN + fi + $CC -shared -Wl,--enable-auto-import -o $LIBNAME "$@" $BIN/iconx.a;; Darwin*) - cc -bundle -undefined suppress -flat_namespace -o $LIBNAME "$@";; + $CC -bundle -undefined suppress -flat_namespace -o $LIBNAME "$@";; SunOS*) $CC $CFLAGS -G -o $LIBNAME "$@" -lc -lsocket;; HP-UX*) diff --git a/ipl/gincl/keysyms.icn b/ipl/gincl/keysyms.icn index 7b0c6a5..b9d316b 100644 --- a/ipl/gincl/keysyms.icn +++ b/ipl/gincl/keysyms.icn @@ -97,6 +97,7 @@ $define Key_Up 65362 $endif $ifdef _MS_WINDOWS +$ifndef _X_WINDOW_SYSTEM $define Key_Down 40 $define Key_End 35 $define Key_ScrollLock 145 @@ -136,6 +137,7 @@ $define Key_Right 39 $define Key_Select 41 $define Key_Up 38 $endif +$endif $ifdef _JAVA $define Key_PrSc 154 diff --git a/ipl/gpacks/weaving/Makefile b/ipl/gpacks/weaving/Makefile index e415e99..9604e8e 100644 --- a/ipl/gpacks/weaving/Makefile +++ b/ipl/gpacks/weaving/Makefile @@ -6,8 +6,8 @@ PROCS = cells.u2 tdialog.u2 tieutils.u2 tpath.u2 \ weavegif.u2 weavutil.u2 wifcvt.u2 -PROGS = comb draw2gmr drawdown drawup gif2geom gif2html heddle lindpath \ - mtrxedit pfd2gif pfd2gmr pfd2ill pfd2wif plexity randweav \ +PROGS = comb draw2gmr drawdown drawup gif2geom gif2html heddle htweav \ + lindpath mtrxedit pfd2gif pfd2gmr pfd2ill pfd2wif plexity randweav \ seqdraft shadow shadpapr showrav tieimage unravel wallpapr weaver wif2pfd diff --git a/ipl/gpacks/weaving/htweav.icn b/ipl/gpacks/weaving/htweav.icn new file mode 100644 index 0000000..351ce50 --- /dev/null +++ b/ipl/gpacks/weaving/htweav.icn @@ -0,0 +1,396 @@ +############################################################################ +# +# File: htweav.icn +# +# Subject: Program to display images as weavable halftones +# +# Author: Gregg M. Townsend +# +# Date: March 20, 2006 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Usage: htweav [winoptions] imagefile... +# +# Htweav reads one or more images and displays modified grayscale versions +# that are "weavable" in the sense that warp and weft colors are assignable +# as in the unravel.icn program. +# +# The display is a fixed 4 x 3 grid of twelve copies of an input image. +# One copy is a dithered, grayscale version of the original. The others +# are weavable patterns based on the dithered image. +# +# The program is controlled by keypresses in the display window. +# Keyboard commands are as follows: +# +# 0 to 9 +# sets the amount of dithering, from none (0) to maximum (9) +# +# R or r +# selects randomized dithering +# +# G or g +# selects "golden" dithering, a regular dithering involving +# use of the golden ratio +# +# S or s +# brings up a dialog box for saving the displayed results +# as a family of GIF files named by extending the entered string +# +# <SPACE> or <ENTER> +# advances to the next input image, if more than one was given +# +# <BS> or <DEL> +# goes back to the previous input image +# +# Q or q +# exits the program +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: graphics +# +############################################################################ + +# TO DO: +# +# The choices of warp and weft threads should be controllable somehow +# without having to edit and recompile the source code. +# +# The hardwired layout of 4 x 3 images should also be adjustable. +# +# There might be other dithering approaches that would work better. +# In particular, consider dithering with error diffusion. +# +# Some sort of dithering that takes the varying thread colors into +# account might do better yet. +# +# Dithering should be done in a linear color space, not a gamma=2.2 +# colorspace. This is tricky because the code is already working +# around Icon's assumption that an input image has a gamma of 1.0 +# instead of the 2.2 that has become nearly universal today. + + +link graphics + + +$define DEFPROC "r" # default dithering procedure +$define DEFNOISE 4 # default dithering level (empirical) + +# display layout +$define NWIDE 4 +$define NHIGH 3 +$define MARGIN 3 + +# program constants (some are not easily changed) +$define ALPHABET "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" # weaving alphabet +$define IPALETTE "g256" # input palette +$define OPALETTE "g64" # output palette + + +# general globals + +global dchar # current dithering procedure selection character +global noise # current noise factor + +global texth # text height for labeling +global row, col # current position for next image to exhibit + +global svname # basename for file saving, if requested + + +# current image globals + +global iname # current image name +global istring # current image string +global iwidth, iheight # current image height +global tmpwin # temporary scratch window, sized for current image + + + +# main procedure + +procedure main(args) + local e + + Window("fg=black", "bg=white", "gamma=1.0", "font=sans,10", + args, "canvas=hidden") + if *args = 0 then stop("usage: ", &progname, " file.gif...") + + dchar := DEFPROC + noise := DEFNOISE + + texth := WAttrib("ascent") + + load(!args) + exhibit() + + while e := Event() do case e of { + QuitEvents(): { break } + !"\n\r ": { put(args, get(args)); load(!args); exhibit(); } + !"\b\d": { push(args, pull(args)); load(!args); exhibit(); } + !"0123456789": { noise := ord(e) - ord(0); exhibit(); } + !"sS": { save() } + !"gGrR": { dchar := map(e); exhibit(); } + } +end + + +# load(fname) -- read image and set global variables + +procedure load(fname) + WClose(\tmpwin) + tmpwin := WOpen("image=" || fname, "gamma=1.0", "canvas=hidden") | + stop("cannot open ", fname) + iname := fname + istring := Capture(tmpwin, IPALETTE) + iwidth := WAttrib(tmpwin, "width") + iheight := WAttrib(tmpwin, "height") + return +end + + +# save() -- save results as a family of GIF images +# +# Gets a basename using a dialog box. +# Saves each image with a different suffix reflecting its parameters. +# Actual work is done as a side effect of draw() calls from exhibit(). + +procedure save() + dialog_value := "" + while *dialog_value = 0 do + case SaveDialog("Save to file names beginning with") of { + "Yes": { + svname := dialog_value + write(&errout, " Saving to ", + svname, ".warp.weft.", dchar, noise, ".gif") + EraseArea() + exhibit() + svname := &null + } + "No": + return + "Cancel": + fail + } +end + + +# exhibit() -- build a windowful of images +# +# Runs through a hardwired sequence of parameter sets, +# displaying all variations. + +procedure exhibit() + local dstring, label + + # configure the display window + WAttrib("width=" || (MARGIN + NWIDE * (iwidth + MARGIN)), + "height=" || (MARGIN + NHIGH * (iheight + texth + MARGIN))) + WAttrib("canvas=normal") # keep this separate (work around iconx bug) + label := iname || " " || dchar || noise # make a label + WAttrib("label=" || label) # label the window + row := col := 0 # initialize posn in window + + # dither the grayscale image + case dchar of { + "g": dstring := goldither(istring) + "r": dstring := randither(istring) + } + + # first row + draw(dstring, label) # original grayscale image + drawweave(dstring, "01", "23") # 2x2 dark x light + drawweave(dstring, "03", "12") # 2x2 interleaved + drawweave(dstring, "0", "1") # simple binary threshold + + # second row + drawweave(dstring, "475869", "ADBECF") # 6x6 dark x light + drawweave(dstring, "012", "345") # 3x3 dark x light + drawweave(dstring, "024", "135") # 3x3 interleaved + drawweave(dstring, "123", "123") # 3x3 all x all + + # third row + drawweave(dstring, "0213", "4657") # 4x4 dark x light + drawweave(dstring, "0102", "5453") # 4x4 alt extremes + drawweave(dstring, "010203", "646566") # 6x6 alt extremes + drawweave(dstring, "14253", "06") # 5x2 mids x extremes + + # not currently displayed + # drawweave(dstring, "0426", "1537") # 4x4 interleaved + # drawweave(dstring, "02413", "57968") # 5x5 dark x light + # drawweave(dstring, "04826", "15937") # 5x5 interleaved + + return +end + + +# drawweave(dstring, warp, weft) -- weave, draw, and label + +procedure drawweave(dstring, warp, weft) + draw(weave(dstring, warp, weft), warp || "." || weft) + return +end + + +# goldither(istring) -- apply golden dithering to image string +# +# Dithering d changes from one pixel to the next by approximately +# d := fractpart(d + &phi) +# +# The actual amount is very slightly different so that the offset +# from one row to the text is independent of the row length. +# Empirically, an offset angle that is arctan(7) seems to work best. + +procedure goldither(istring) + local s, c, i, v, dv + + dv := (integer(iwidth * &phi) + (1./7.)) / iwidth # 7 is relatively prime + istring ? { + s := tab(upto(',') + 1) || tab(upto(',') + 1) # width and palette + v := 0.0 + while c := move(1) do { + v := v + dv + v := v - integer(v) + i := ord(c) + 16 * noise * (v - 0.5) + i <:= 0 + i >:= 255 + s ||:= char(i) + } + return s + } +end + + +# randither(istring) -- apply random dithering to image string + +procedure randither(istring) + local s, c, i + + istring ? { + s := tab(upto(',') + 1) || tab(upto(',') + 1) # width and palette + while c := move(1) do { + i := ord(c) + 16 * noise * (?0 - 0.5) + i <:= 0 + i >:= 255 + s ||:= char(i) + } + return s + } +end + + +# draw(istring, label) -- draw image at next open position + +procedure draw(istring, label) + local x, y + + x := MARGIN + col * (iwidth + MARGIN) + y := MARGIN + row * (iheight + MARGIN + texth) + EraseArea(x + iwidth, y, MARGIN, iheight + MARGIN) + EraseArea(x, y + iheight, iwidth + MARGIN, texth + MARGIN) + DrawImage(x, y, istring) + DrawString(x, y + iheight + texth, \label) + col +:= 1 + if col >= NWIDE then { + col := 0 + row +:= 1 + } + return +end + + +# weave(istring, warp, weft) -- produce a weavable version of an image string +# +# The warp and weft arguments are implicitly replicated as needed to match +# the width and height of the image. Each is a string from the alphabet +# 0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ +# where the smallest and largest characters used by either string are +# taken to stand for black and white respectively, with uniform gradation +# for any characters between. + +procedure weave(istring, warp, weft) + local maps, row, m, i, s, n, svfile + + warp := map(warp, &lcase, &ucase) + weft := map(weft, &lcase, &ucase) + maps := mappings(warp, weft) + n := *(warp ++ weft) + + s := iwidth || "," || OPALETTE || "," + istring ? { + tab(upto(',') + 1) # skip width + tab(upto(',') + 1) # skip palette + while row := move(iwidth) do { + put(maps, m := get(maps)) # rotate mappings to next row + every i := 1 to *row do + s ||:= m[(i - 1) % *m + 1][ord(row[i]) + 1] + } + } + + if \svname then { + svfile := svname || + "." || warp || "." || weft || "." || dchar || noise || ".gif" + DrawImage(tmpwin, 0, 0, s) + WriteImage(tmpwin, svfile) + } + + return s +end + + +# mappings(warp, weft) -- produce mappings to output characters +# +# Returns a 2-D list of mappings that translate input indexes from the +# g256 palette to output palette (OPALETTE=g64) indexes. + +procedure mappings(warp, weft) + local pmap, all, mlist, row, c + + all := warp ++ weft + mlist := [] + every c := !weft do { + put(mlist, row := []) + every put(row, onemap(all, !warp, c)) + } + return mlist +end + + +# onemap(all, warpc, weftc) -- produce one mapping to warpc and weftc. +# +# Generates a mapping from input graylevel to one of two output graylevels, +# warpc and weftc, which are chosen from the range in the first argument. + +procedure onemap(all, warpc, weftc) + local c1, c2, g1, g2, n, s + + g1 := grayval(all, warpc) + g2 := grayval(all, weftc) + if g1 > g2 then g1 :=: g2 + c1 := PaletteKey(OPALETTE, g1 || "," || g1 || "," || g1) + c2 := PaletteKey(OPALETTE, g2 || "," || g2 || "," || g2) + n := (g1 + g2) / 512 + s := repl(c1, n) || repl(c2, 256 - n) + return s +end + + +# grayval(all, c) -- return value of c in the range specified by all. + +procedure grayval(all, c) + local a, b + + a := find(all[1], ALPHABET) + b := find(all[-1], ALPHABET) + c := find(c, ALPHABET) + return integer(65535 * (c - a) / real(b - a) + 0.5) +end diff --git a/ipl/gpacks/xtiles/README b/ipl/gpacks/xtiles/README index c735eda..7668421 100644 --- a/ipl/gpacks/xtiles/README +++ b/ipl/gpacks/xtiles/README @@ -8,9 +8,7 @@ Installation first. Confere ftp://ftp.cs.arizona.edu/pub/Icon for that. Tiles should work as-is with Icon v9.0 and higher. - Compile X-Tiles with either icont/iconc as you wish. - - Check that it works. + Compile X-Tiles and check that it works. Copy the executable and the man page where you want. diff --git a/ipl/gprogs/breakout.icn b/ipl/gprogs/breakout.icn index 28559f1..56b0551 100644 --- a/ipl/gprogs/breakout.icn +++ b/ipl/gprogs/breakout.icn @@ -6,7 +6,7 @@ # # Author: Nathan J. Ranks # -# Date: September 3, 2000 +# Date: November 22, 2009 # ############################################################################ # @@ -49,13 +49,21 @@ procedure main() WOpen("size=293,320") | stop("can't open window") - sphere := "3,g16,~0~_ - 000_ - ~0~" #black sphere - - blank := "3,g16,~F~_ - FFF_ - ~F~" #white sphere to erase + sphere := "7,g16,~~000~~_ + ~00000~_ + 0000000_ + 0000000_ + 0000000_ + ~00000~_ + ~~000~~" #black sphere + + blank := "7,g16,~~FFF~~_ + ~FFFFF~_ + FFFFFFF_ + FFFFFFF_ + FFFFFFF_ + ~FFFFF~_ + ~~FFF~~" #white sphere to erase level := 1 #default start level create_blocks() #as the name suggests diff --git a/ipl/gprogs/gallery.icn b/ipl/gprogs/gallery.icn index 4dcd0a7..2379f99 100644 --- a/ipl/gprogs/gallery.icn +++ b/ipl/gprogs/gallery.icn @@ -6,7 +6,7 @@ # # Author: Gregg M. Townsend # -# Date: August 3, 2005 +# Date: May 27, 2008 # ############################################################################ # @@ -35,11 +35,10 @@ # The right mouse button activates the same popup momentarily until # the button is released. # -# -wnnn sets the maximum width for displaying an image; -# -hnnn sets the maximum height. -snnn sets both. -# By default, sizes are chosen automatically, subject to a minimum -# size of 32x32, to allow all images to fit in a single window. -# +# -wnnn sets the minimum thumbnail width. The default is 32. +# -hnnn sets the minimum thumbnail height. The default is 32. +# -snnn sets the minimum height and width together. +# # -r arranges images in rows instead of columns. # -m maximizes the window size before displaying images. # -t trims file names of leading path components and extensions. @@ -124,13 +123,11 @@ procedure main(args) else fh := WAttrib("fheight") fw := WAttrib("fwidth") - maxw := \opts["w"] | \opts["s"] | 2 * \opts["h"] - maxh := \opts["h"] | \opts["s"] | 2 * \opts["w"] - - # If no image size specified, try to guess to fill the window - if /maxw then - layout(*args) + # Determine thumbnail sizes. + layout(*args) + maxw <:= \opts["w"] | \opts["s"] | 2 * \opts["h"] + maxh <:= \opts["h"] | \opts["s"] | 2 * \opts["w"] aspmax := real(maxw) / real(maxh) # Display the files. @@ -149,7 +146,7 @@ procedure main(args) return # Get the next file and translate its image. - f := open(fname) | + f := open(fname, "ru") | { write(&errout, fname, ": can't open"); next } # Read the image, full sized, into a scratch canvas @@ -345,7 +342,7 @@ end procedure popinfo(a, e, w, h) local f, i, n, x, y - f := open(a.fname) + f := open(a.fname, "ru") seek(f, 0) n := where(f) seek(f, 1) @@ -445,7 +442,7 @@ procedure mkgif(cmd, fname) if \opts["d"] then write(&errout, "+ ", cmd) system(cmd) - f := open(tempname) | fail + f := open(tempname, "ru") | fail win := load(tempname) close(f) remove(tempname) @@ -486,7 +483,7 @@ procedure jsize(irec, fname) local s, p, line, w, h s := "" - p := open("rdjpgcom -verbose " || fname, "p") | fail + p := open("rdjpgcom -verbose \"" || fname || "\"", "p") | fail while line := read(p) do line ? { ="JPEG image is " | next w := tab(many(&digits)) | next diff --git a/ipl/gprogs/kaleid.icn b/ipl/gprogs/kaleid.icn index 11b3ed9..cfb825d 100644 --- a/ipl/gprogs/kaleid.icn +++ b/ipl/gprogs/kaleid.icn @@ -6,7 +6,7 @@ # # Author: Stephen B. Wampler # -# Date: May 2, 2001 +# Date: November 22, 2009 # ############################################################################ # @@ -218,6 +218,7 @@ local radius, xoff, yoff # draw it in kaleidoscopic form draw_circle(mid_win-yoff, mid_win+xoff, radius) draw_circle(mid_win-yoff, mid_win-xoff, radius) + WDelay(10) return end diff --git a/ipl/gprogs/spider.icn b/ipl/gprogs/spider.icn index 0c25529..10ed22a 100644 --- a/ipl/gprogs/spider.icn +++ b/ipl/gprogs/spider.icn @@ -6,7 +6,9 @@ # # Author: William S. Evans # -# Date: February 19, 2002 +# Contributor: Gregg M. Townsend +# +# Date: September 6, 2009 # ############################################################################ # @@ -45,6 +47,11 @@ # 's' Save the current game to a file. # 'r' Read a game from a file. # '1234567890' Move run from indicated pile. +# 'bfhptvwxyz' Move run from indicated pile. +# +# If $HOME/.spdhist exists and is writable at the start of the run, a +# single history record is written to it for each 'n' or 'q' or 'r' +# command, unless no cards have been moved. # ############################################################################ # @@ -52,15 +59,20 @@ # ############################################################################ # -# Links: drawcard, graphics, random +# Links: datetime, drawcard, graphics, random # ############################################################################ +link datetime link drawcard link graphics link random $define SPIDER_VERSION "spider-0.3" # version of spider +$define HISTORY_FILE ".spdhist" # name of history file in $HOME + +$define NUM_LABELS "1234567890" # numeric column labels +$define LTR_LABELS "bfhptvwxyz" # alphabetic column labels global cardw, cardh # card width and height global ymargin, xmargin, xgap # margins, gap between cards @@ -74,6 +86,8 @@ global nextCard # an integer global undoStack # list of integers global currentFile # filename to store/retrieve a game global readingGame # =1 if reading game from file =0 o.w. +global startTime # start time of this game +global histfile # appendable history file, if any, else null procedure main(args) local fromPile,maxCards,e,p @@ -82,6 +96,7 @@ procedure main(args) newgame() repeat case e := Event() of { !"qQ": { + report() exit() } "d": { @@ -94,26 +109,29 @@ procedure main(args) message(hiddenNames(1+(&x-xmargin+xgap/2)/(cardw+xgap))) } "n": { + report() newgame() } "u": { undo() | beep() } "r": { + report() readingGame := 1 WAttrib("bg=pale gray","fg=black") readFile() readingGame := 0 WAttrib("bg=deep moderate green","fg=white") drawBoard() + startTime := &null # unknown original start time } "s": { WAttrib("bg=pale gray","fg=black") saveFile() WAttrib("bg=deep moderate green","fg=white") } - !"1234567890": { - p := 0 < ord(e)-ord("0") | 10 + !(NUM_LABELS | LTR_LABELS): { + p := find(e, NUM_LABELS | LTR_LABELS) click(13,p,p) | beep() } &lpress | &rpress: { @@ -138,6 +156,7 @@ procedure main(args) end procedure initialize(args) + local hfname currentFile := "game1.spd" readingGame := 0 @@ -171,6 +190,10 @@ procedure initialize(args) ymargin <:= fheight + hfname := (getenv("HOME") | "?noHOME?") || "/" || HISTORY_FILE + if close(open(hfname)) then # if file already exists + histfile := open(hfname, "wa") # may fail leaving null if not writable + return end @@ -205,12 +228,19 @@ procedure newgame(initialDeck) up[11] := 0 drawBoard() + + startTime := &clock return end procedure drawPiles(p[]) local i,j,n,x,y,ht,mlap,upstart,yposns + if *pile[11] = 104 then { + drawWin() + return + } + if readingGame = 0 then { every i := 1 <= 10 >= !p do { @@ -219,8 +249,8 @@ procedure drawPiles(p[]) yoff[i] := yposns := list(0) x := xmargin + (i-1) * (cardw + xgap) EraseArea(x,ymargin,cardw,height-2*ymargin) - GotoXY(x+cardw/2,ymargin-descent) - WWrites(10 > i | 0) + GotoXY(x+cardw/2-10,ymargin-descent) + WWrites(LTR_LABELS[i], " ", NUM_LABELS[i]) n := *(pile[i]) mlap := lap if n > 1 then @@ -247,9 +277,28 @@ procedure drawPiles(p[]) return end +procedure drawWin() + local i, j, s, x, y, suits + + EraseArea() + suits := [ + "MLKJIHGFEDCBA", "mlkjihgfedcba", "zyxwvutsrqpon", "ZYXWVUTSRQPON" ] + every i := 1 to 4 do { + s := suits[i] + y := 125 * (i - 1) + every x := 20 | 400 do { + every j := 1 to 13 do { + drawcard(x + 24 * j, y, s[j]) + WDelay(5) + } + } + } + return +end procedure drawBoard() if readingGame = 0 then { + EraseArea() WAttrib("label=Spider Deck "||104-nextCard+1) drawPiles(1,2,3,4,5,6,7,8,9,10) } @@ -424,8 +473,8 @@ procedure succ(c) end procedure beep() - writes("\^g") - flush(&output) + writes(&errout, "\^g") + flush(&errout) return end @@ -505,6 +554,7 @@ procedure saveFile() write(output,deck) every writes(output,!undoStack," ") write(output,"") + close(output) return } else { Notice("Cannot open file for writing.") @@ -565,3 +615,41 @@ procedure doAll() } return end + +procedure report() + local i, u, s, stopTime, elapsed, nmoves, undealt, cardsleft + + if *undoStack = 0 then return # don't report if no moves made + + stopTime := &clock + elapsed := ClockToSec(stopTime,0) - (ClockToSec(\startTime,0)|-1) + if elapsed < 0 then # if wraparound crossing midnight + elapsed +:= 24 * 60 * 60 + elapsed >:= 9999 # 9999 sec means unknown or bogus time + + nmoves := *undoStack/3 + undealt := 104 - nextCard + 1 + cardsleft := 0 + every cardsleft +:= *pile[1 to 10] + write(nmoves, " moves in ", elapsed, " seconds, leaving ", + cardsleft + undealt, " cards") + + if /histfile then return # if no history file, nothing more to do + + writes(histfile, &date, " ", stopTime[1+:5]) # date and time at quit + writes(histfile, right(elapsed, 5), "s") # elapsed time in sec + writes(histfile, right(nmoves, 4), "m") # moves made + writes(histfile, right(undealt, 3), "c") # undealt cards + + every i := 1 to 10 do { + s := pile[i] + u := up[i] + if *s = 0 then + writes(histfile, " -") + else + writes(histfile, " ", s[1+:u], repl("?", *s-u)) + } + + write(histfile) + return +end diff --git a/ipl/gprogs/trkvu.icn b/ipl/gprogs/trkvu.icn index 9cd3c36..18c9f39 100644 --- a/ipl/gprogs/trkvu.icn +++ b/ipl/gprogs/trkvu.icn @@ -6,7 +6,7 @@ # # Authors: Gregg M. Townsend # -# Date: October 1, 2005 +# Date: April 3, 2010 # ############################################################################ # @@ -34,7 +34,7 @@ # # Track log colorings are selected by pressing a key: # -# F color by File +# F color by File (restricting legend to files in view) # A color by Age # O color by Orientation (direction of travel) # V color by Velocity @@ -105,7 +105,7 @@ record view( # one view of data record point( # one point along a track t, # time at point (real days & fraction since epoch) x, y, # coordinates of point (longitude, latitude) - fhue) # hue assigned to original source file + f) # file index global viewlist # list of views (view records) @@ -208,13 +208,10 @@ end procedure load(fname) # load data from one file local f, h, p, w, t, x, y, a, line, ptlist - static n - initial n := 0 f := open(fname) | stop("cannot open ", fname) - h := huenum(n +:= 1) put(fnlist, fname) - put(fhlist, h) + put(fhlist, huenum(*fnlist)) while line := read(f) do { every put(w := [], words(line)) if -90.0 <= numeric(w[-3]) <= 90.0 then @@ -222,7 +219,7 @@ procedure load(fname) # load data from one file if x := numeric(w[-1]) & y := numeric(w[-2]) then { t := tcrack(w[-4], w[-3]) | &null /ptlist := [] - put(ptlist, p := point(t, x, y, h)) + put(ptlist, p := point(t, x, y, *fnlist)) } else { put(seglist, \ptlist) @@ -245,7 +242,7 @@ procedure tcrack(date, time) # translate date + time into real value if date[3] == "/" then date := map("CcYy/Mm/Dd", "Mm/Dd/CcYy", date) - if date == ("1989/12/31" | "1990/01/01") then + if date <<= "1990/01/01" then # if indicator of missing date return &null *time = 8 | fail *date = 10 | fail @@ -387,7 +384,7 @@ procedure draw(win, pjn, a) # display map using curview GotoXY(2 * BORDER, lbase) ltext(curview.ltitle) ltext(": ") - curview.lproc() + curview.lproc(pjn) Clip ! mclip every ptlist := !seglist do { @@ -460,17 +457,48 @@ end # F: color segments by source file, using colors set at load time +# +# show in the legend only those files containing a point in view +# (note: won't show legend for tracks that "just pass through") + +procedure flegend(pjn) + local winlim, viewlim, fset, vset, i, seg, pt, x0, x1, y0, y1 + + fset := set() # set of potential file source indices + every insert(fset, 1 to *fnlist) + vset := set() # set of indices of files in view + + # find limits of the current field of view + winlim := [mclip[1], mclip[2] + mclip[4], mclip[1] + mclip[3], mclip[2]] + viewlim := project(invp(pjn), winlim) + x0 := get(viewlim) + y0 := get(viewlim) + x1 := get(viewlim) + y1 := get(viewlim) + + # find files in view + every seg := !seglist do { + pt := !seg # first pt + if member(fset, pt.f) then { + every pt := !seg do { + if x0 <= pt.x <= x1 & y0 <= pt.y <= y1 then { + delete(fset, pt.f) + insert(vset, pt.f) + if *fset = 0 then + break break + } + } + } + } -procedure flegend() - local i - - every i := 1 to *fnlist do + # now, finally draw the legend + every i := !sort(vset) do lhue(fhlist[i], fnlist[i] || " ") return end procedure byfile(p, q) - return q.fhue + return fhlist[q.f] end diff --git a/ipl/gprogs/tron.icn b/ipl/gprogs/tron.icn new file mode 100644 index 0000000..7fefc04 --- /dev/null +++ b/ipl/gprogs/tron.icn @@ -0,0 +1,191 @@ +############################################################################ +# +# File: tron.icn +# +# Subject: Program to play a Tron-like video game +# +# Author: Eduardo Ochs <eduardoochs@gmail.com> +# +# Date: November 18, 2009 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# Rules: You're yellow, and you leave a yellow trail when you walk. +# You never stop until you die. You die when you hit something +# yellow. Use the arrow keys to change your direction. Try to make +# the best score you can before you die. You only live once. +# +# In the beginning it's a black arena with yellow walls and a red +# 3x3 pixel square somewhere. Walking over a red pixel gives you +# one point and makes another 3x3 square appear somewhere. So, +# crossing a 3x3 red square from one side to another gives you +# three points and makes three other squares appear in random +# positions. +# +# Walking over black pixels is harmless. +# +# Sometimes the red squares will appear over your trail. Then some +# pixels of your trail will become red and you'll be able to cross. +# +# The game loop and the outer loop: typing "Q" or Esc or losing when +# you're playing makes you go to the outer loop; in the outer loop +# typing "P" or Enter or space restarts the game, and typing "Q" or +# Esc leaves the program. +# +# Source: <http://angg.twu.net/ICON/tron.icn> +# Htmlized: <http://angg.twu.net/ICON/tron.icn.html> +# Screenshot: <http://angg.twu.net/ICON/tron.icn.png> +# See also: <http://angg.twu.net/elisp/tron.el.html> +# <http://angg.twu.net/elisp/tron.el.png> +# +############################################################################ +# +# Requires: Version 9 graphics +# +############################################################################ +# +# Links: graphics, random +# +############################################################################ + +link graphics +link random + +$include "keysyms.icn" + +global actions, direction +global x, y, dx, dy +global score +global pixels + +procedure prepare_vars() + actions := table() + actions[Key_Down] := ["v", +1] + actions[Key_Up] := ["v", -1] + actions[Key_Right] := ["h", +1] + actions[Key_Left] := ["h", -1] + every actions["q" | "Q" | "\e"] := "quit" + set_direction(["h", +1]) + x := 150 + y := 90 + score := 0 + pixels := table() + every pixels[0 to 199] := table(0) +end + +procedure set_color(n) + if n == 0 then WAttrib("fg=black") + if n == 1 then WAttrib("fg=red") + if n == 3 then WAttrib("fg=yellow") +end + +procedure pset(x, y, color) + set_color(color) + pixels[y][x] := color + FillRectangle(x*2, y*2, 2, 2) +end + +procedure point(x, y) + return pixels[y][x] +end + +procedure draw_red_square() + local x, y + x := ?316 + y := ?188 + every pset(x to x+2, y to y+2, 1) +end + +procedure is_direction(action) + return type(action) == "list" +end + +procedure ignored_turn(newdirection) + return newdirection[1] == direction[1] +end + +procedure set_direction(newdirection) + direction := newdirection + if direction[1] == "h" then { + dx := direction[2]; dy := 0 + } else { + dy := direction[2]; dx := 0 + } +end + +procedure process_events() + local e, action + while *Pending() > 0 do { + e := Event() + # w(e) + action := actions[e] + if is_direction(action) then { + if not ignored_turn(action) then { + set_direction(action) + return + } + } + if action === "quit" then + fail + } + return +end + +procedure prepare_walls() + every pset(0 to 319, 0, 3) + every pset(0 to 319, 191, 3) + every pset(0, 0 to 191, 3) + every pset(319, 0 to 191, 3) +end + +procedure draw_score() + GotoXY(6, 396) + set_color(3) + WWrites("Score: " || score) +end + +procedure play() + prepare_vars() + set_color(0) + FillRectangle(0, 0, 640, 400) + prepare_walls() + pset(x, y, 3) + draw_red_square() + draw_score() + + WDelay(1000) + + while process_events() do { + x +:= dx + y +:= dy + if point(x, y) == 3 then break + if point(x, y) == 1 then { + draw_red_square(); score +:= 1; draw_score() + pset(x, y, 3) + WDelay(50) + } + pset(x, y, 3) + WDelay(50) + } +end + +procedure main(args) + local e + + # w(actions) + WOpen("size=640,400", "fg=yellow", "bg=black") + WAttrib("font=Helvetica,12,bold") + + randomize() + while 1 do { + play() + while e := Event() do { + if e === ("q" | "Q" | "\e") then return + if e === ("p" | "P" | " " | "\r" | "\n") then break + } + } +end diff --git a/ipl/mincl/etdefs.icn b/ipl/mincl/etdefs.icn deleted file mode 100644 index 7634a74..0000000 --- a/ipl/mincl/etdefs.icn +++ /dev/null @@ -1,39 +0,0 @@ -############################################################################ -# -# File: etdefs.icn -# -# Subject: Definitions for artificial event codes -# -# Author: Ralph E. Griswold -# -# Date: August 16, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This file contains definitions for event codes. -# -# This file is intended for use with event monitors running under -# MT Icon. -# -############################################################################ - -$define T_01 "A" -$define T_02 "B" -$define T_03 "C" -$define T_04 "D" -$define T_05 "E" -$define T_06 "F" -$define T_07 "G" -$define T_08 "H" -$define T_09 "I" -$define T_10 "J" -$define T_11 "K" -$define T_12 "L" -$define T_13 "M" -$define T_14 "N" - -$define T_Mask1 cset("ABCDEFGHIJKLM") diff --git a/ipl/mincl/evdefs.icn b/ipl/mincl/evdefs.icn deleted file mode 100644 index 4f76077..0000000 --- a/ipl/mincl/evdefs.icn +++ /dev/null @@ -1,191 +0,0 @@ -############################################################################ -# -# File: evdefs.icn -# -# Subject: Definitions for event codes -# -# Author: Ralph E. Griswold -# -# Date: February 28, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This file contains definitions for event codes. -# -# This file is intended for use with event monitors running under -# MT Icon. -# -############################################################################ -# -# This file is generated automatically from monitor.h. -# -############################################################################ - -$define T_Coexpr 19 -$define T_Cset 5 -$define T_External 20 -$define T_File 6 -$define T_Integer 2 -$define T_Kywdevent 26 -$define T_Kywdint 21 -$define T_Kywdpos 22 -$define T_Kywdstr 25 -$define T_Kywdsubj 23 -$define T_Kywdwin 24 -$define T_Lelem 10 -$define T_List 9 -$define T_Lrgint 3 -$define T_Null 1 -$define T_Proc 7 -$define T_Real 4 -$define T_Record 8 -$define T_Refresh 18 -$define T_Selem 12 -$define T_Set 11 -$define T_Slots 16 -$define T_String 0 -$define T_Table 13 -$define T_Telem 14 -$define T_Tvsubs 17 -$define T_Tvtbl 15 -$define E_Aconv "\111" # Conversion attempt -$define E_Alien "\172" # Alien allocation -$define E_Assign "\347" # Assignment -$define E_BlkDeAlc "\055" # Block deallocation -$define E_Bsusp "\142" # Suspension from operation -$define E_Coact "\101" # Co-expression activation -$define E_Coexpr "\170" # Co-expression allocation -$define E_Cofail "\104" # Co-expression failure -$define E_Collect "\107" # Garbage collection -$define E_Coret "\102" # Co-expression return -$define E_Cset "\145" # Cset allocation -$define E_Ecall "\143" # Call of operation -$define E_Efail "\146" # Failure from expression -$define E_EndCollect "\360" # End of garbage collection -$define E_Erem "\166" # Removal of a suspended generator -$define E_Eresum "\165" # Resumption of expression -$define E_Error "\105" # Run-time error -$define E_Esusp "\141" # Suspension from alternation -$define E_Exit "\130" # Program exit -$define E_External "\152" # External allocation -$define E_Fcall "\072" # Function call -$define E_Fconv "\112" # Conversion failure -$define E_Ffail "\115" # Function failure -$define E_File "\147" # File allocation -$define E_Free "\132" # Free region -$define E_Frem "\133" # Function suspension removal -$define E_Fresum "\131" # Function resumption -$define E_Fret "\120" # Function return -$define E_Fsusp "\127" # Function suspension -$define E_Intcall "\351" # interpreter call -$define E_Integer "\100" # Integer value pseudo-event -$define E_Intret "\352" # interpreter return -$define E_Kywdint "\136" # Integer keyword value pseudo-event -$define E_Kywdpos "\046" # Position value pseudo-event -$define E_Kywdsubj "\052" # Subject value pseudo-event -$define E_Lbang "\301" # List generation -$define E_Lcreate "\302" # List creation -$define E_Lelem "\155" # List element allocation -$define E_Lget "\356" # List get/pop -- only E_Lget used -$define E_Line "\355" # Line change -$define E_List "\153" # List allocation -$define E_Loc "\174" # Location change -$define E_Lpop "\356" # List get/pop -$define E_Lpull "\304" # List pull -$define E_Lpush "\305" # List push -$define E_Lput "\306" # List put -$define E_Lrand "\307" # List random reference -$define E_Lref "\310" # List reference -$define E_Lrgint "\114" # Large integer allocation -$define E_Lsub "\311" # List subscript -$define E_Lsusp "\154" # Suspension from limitation -$define E_MXevent "\370" # monitor input event -$define E_Nconv "\116" # Conversion not needed -$define E_Null "\044" # Null value pseudo-event -$define E_Ocall "\134" # Operator call -$define E_Ofail "\135" # Operator failure -$define E_Opcode "\117" # Virtual-machine instruction -$define E_Orem "\177" # Operator suspension removal -$define E_Oresum "\175" # Operator resumption -$define E_Oret "\140" # Operator return -$define E_Osusp "\173" # Operator suspension -$define E_Pcall "\103" # Procedure call -$define E_Pfail "\106" # Procedure failure -$define E_Prem "\126" # Suspended procedure removal -$define E_Presum "\125" # Procedure resumption -$define E_Pret "\122" # Procedure return -$define E_Proc "\045" # Procedure value pseudo-event -$define E_Psusp "\123" # Procedure suspension -$define E_Rbang "\312" # Record generation -$define E_Rcreate "\313" # Record creation -$define E_Real "\144" # Real allocation -$define E_Record "\150" # Record allocation -$define E_Refresh "\171" # Refresh allocation -$define E_Rrand "\314" # Record random reference -$define E_Rref "\315" # Record reference -$define E_Rsub "\316" # Record subscript -$define E_Sbang "\317" # Set generation -$define E_Sconv "\121" # Conversion success -$define E_Screate "\320" # Set creation -$define E_Sdelete "\321" # Set deletion -$define E_Selem "\164" # Set element allocation -$define E_Set "\161" # Set allocation -$define E_Sfail "\341" # Scanning failure -$define E_Sinsert "\322" # Set insertion -$define E_Slots "\167" # Hash header allocation -$define E_Smember "\323" # Set membership -$define E_Snew "\340" # Scanning environment creation -$define E_Spos "\346" # Scanning position -$define E_Srand "\336" # Set random reference -$define E_Srem "\344" # Scanning environment removal -$define E_Sresum "\343" # Scanning resumption -$define E_Ssasgn "\354" # Sub-string assignment -$define E_Ssusp "\342" # Scanning suspension -$define E_Stack "\353" # stack depth -$define E_StrDeAlc "\176" # String deallocation -$define E_String "\163" # String allocation -$define E_Sval "\324" # Set value -$define E_Table "\156" # Table allocation -$define E_Tbang "\325" # Table generation -$define E_Tconv "\113" # Conversion target -$define E_Tcreate "\326" # Table creation -$define E_Tdelete "\327" # Table deletion -$define E_Telem "\157" # Table element allocation -$define E_TenureBlock "\362" # Tenure a block region -$define E_TenureString "\361" # Tenure a string region -$define E_Tick "\056" # Clock tick -$define E_Tinsert "\330" # Table insertion -$define E_Tkey "\331" # Table key generation -$define E_Tmember "\332" # Table membership -$define E_Trand "\337" # Table random reference -$define E_Tref "\333" # Table reference -$define E_Tsub "\334" # Table subscript -$define E_Tval "\335" # Table value -$define E_Tvsubs "\151" # Substring tv allocation -$define E_Tvtbl "\160" # Table-element tv allocation -$define E_Value "\350" # Value assigned -$define E_Disable 1000000 -$define E_Enable 1000001 -$define E_Quit 1000002 -$define E_ALoc 2000000 -$define E_Spoof 1728345 -$define AllocMask cset(E_List || E_Lelem || E_File || E_Lrgint || E_Real || E_Record || E_Selem || E_Set || E_Slots || E_Table || E_Telem || E_Tvsubs || E_Tvtbl || E_Cset || E_Refresh || E_String || E_Coexpr) -$define AssignMask cset(E_Assign || E_Value) -$define TypeMask AllocMask ++ (E_Integer || E_Null || E_Proc) -$define ConvMask cset(E_Aconv || E_Tconv || E_Sconv || E_Nconv || E_Fconv) -$define ProcMask cset(E_Pcall || E_Pfail || E_Pret || E_Psusp || E_Presum || E_Prem) -$define FncMask cset(E_Fcall || E_Ffail || E_Fret || E_Fsusp || E_Fresum || E_Frem) -$define OperMask cset(E_Ocall || E_Ofail || E_Oret || E_Osusp || E_Oresum || E_Orem) -$define EvalMask (FncMask ++ ProcMask ++ OperMask) -$define ListMask cset(E_Lbang || E_Lcreate || E_Lpop || E_Lpull || E_Lpush || E_Lput || E_Lrand || E_Lsub) -$define RecordMask cset(E_Rbang || E_Rcreate || E_Rrand || E_Rsub) -$define ScanMask cset(E_Snew || E_Sfail || E_Spos || E_Ssusp || E_Sresum || E_Srem) -$define SetMask cset(E_Sbang || E_Screate || E_Sdelete || E_Sinsert || E_Smember || E_Sval) -$define TableMask cset(E_Tbang || E_Tcreate || E_Tdelete || E_Tinsert || E_Tkey || E_Tmember || E_Trand || E_Tsub) -$define StructMask ListMask ++ RecordMask ++ SetMask ++TableMask -$define EmptyMask '' -$define AllMask &cset diff --git a/ipl/mprocs/colormap.icn b/ipl/mprocs/colormap.icn deleted file mode 100644 index 2bfcd70..0000000 --- a/ipl/mprocs/colormap.icn +++ /dev/null @@ -1,232 +0,0 @@ -############################################################################ -# -# File: colormap.icn -# -# Subject: Procedures to map type event to color -# -# Author: Ralph E. Griswold -# -# Date: July 1, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# colormap(palette) returns a table that maps event-monitoring codes -# for allocation events into RGB specifications for Icon. The -# argument is the name of a palette, as given in the MemMon -# system. The default for palette is "standard". -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -procedure colormap(palette) - static maps - local x - - initial { - maps := table() - -# Color map for doc.clr - - x := table() - - x[E_Coexpr] := "18724,18724,18724" - x[E_String] := "65535,65535,65535" - x[E_Tvsubs] := "65535,65535,65535" - x[E_File] := "56172,56172,56172" - x[E_Refresh] := "18724,18724,18724" - x[E_Lrgint] := "65535,65535,65535" - x[E_Real] := "65535,65535,65535" - x[E_Record] := "28086,28086,28086" - x[E_Set] := "28086,28086,28086" - x[E_Selem] := "46810,46810,46810" - x[E_List] := "18724,18724,18724" - x[E_Lelem] := "37448,37448,37448" - x[E_Table] := "18724,18724,18724" - x[E_Telem] := "56172,56172,56172" - x[E_Tvtbl] := "37448,37448,37448" - x[E_Slots] := "28086,28086,28086" - x[E_Cset] := "46810,46810,46810" - - maps["doc"] := x - -# Color map for lw.clr - - x := table() - - x[E_Coexpr] := "28086,28086,28086" - x[E_String] := "65535,65535,65535" - x[E_Tvsubs] := "65535,65535,56172" - x[E_File] := "09362,00000,00000" - x[E_Refresh] := "09362,00000,00000" - x[E_Lrgint] := "65535,65535,65535" - x[E_Real] := "65535,65535,65535" - x[E_Record] := "65535,65535,65535" - x[E_Set] := "09362,18724,18724" - x[E_Selem] := "09362,18724,18724" - x[E_List] := "37448,37448,37448" - x[E_Lelem] := "37448,37448,37448" - x[E_Table] := "65535,65535,56172" - x[E_Telem] := "65535,65535,56172" - x[E_Tvtbl] := "65535,65535,56172" - x[E_Slots] := "18724,18724,18724" - x[E_Cset] := "09362,09362,09362" - - maps["lw"] := x - -# Color map for pastel.clr - - x := table() - - x[E_Coexpr] := "65535,46810,28086" # peach - x[E_String] := "56172,28086,09362" # reddish brown - x[E_Tvsubs] := "56172,28086,09362" # reddish brown - x[E_File] := "00000,00000,28086" # dark blue - x[E_Refresh] := "37448,00000,00000" # dark red - x[E_Lrgint] := "65535,65535,00000" # yellow - x[E_Real] := "65535,28086,28086" # salmon - x[E_Record] := "65535,46810,28086" # peach - x[E_Set] := "56172,46810,65535" # light purple - x[E_Selem] := "56172,28086,65535" # medium purple - x[E_List] := "18724,37448,56172" # medium blue - x[E_Lelem] := "18724,56172,65535" # pastel blue - x[E_Table] := "46810,65535,37448" # light yellow-green - x[E_Telem] := "18724,56172,18724" # light green - x[E_Tvtbl] := "09362,37448,09362" # dark green - x[E_Slots] := "37448,65535,65535" # light blue - x[E_Cset] := "65535,65535,46810" # ivory - - maps["pastel"] := x - -# Color map for qms.clr - - x := table() - - x[E_Coexpr] := "37448,18724,00000" # brown - x[E_String] := "65535,65535,46810" # ivory - x[E_Tvsubs] := "65535,65535,46810" # ivory - x[E_File] := "56172,65535,00000" # light green - x[E_Refresh] := "37448,18724,00000" # brown - x[E_Lrgint] := "65535,46810,28086" # peach - x[E_Real] := "65535,65535,00000" # yellow - x[E_Record] := "56172,00000,65535" # magenta - x[E_Set] := "37448,00000,00000" # medium red - x[E_Selem] := "65535,00000,00000" # red - x[E_List] := "00000,46810,46810" # medium cyan - x[E_Lelem] := "00000,65535,65535" # cyan - x[E_Table] := "00000,37448,00000" # dark green - x[E_Telem] := "00000,65535,00000" # green - x[E_Tvtbl] := "28086,65535,00000" # light green - x[E_Slots] := "37448,00000,56172" # purple - x[E_Cset] := "65535,56172,00000" # yellow orange - - maps["qms"] := x - -# Color map for qmscomb.clr - - x := table() - - x[E_Coexpr] := "37448,18724,00000" # brown - x[E_String] := "65535,65535,46810" # ivory - x[E_Tvsubs] := "65535,65535,46810" # ivory - x[E_File] := "56172,65535,00000" # light green - x[E_Refresh] := "37448,18724,00000" # brown - x[E_Lrgint] := "65535,46810,28086" # peach - x[E_Real] := "65535,65535,00000" # yellow - x[E_Record] := "56172,00000,65535" # magenta - x[E_Set] := "65535,00000,00000" # red - x[E_Selem] := "65535,00000,00000" # red - x[E_List] := "00000,65535,65535" # cyan - x[E_Lelem] := "00000,65535,65535" # cyan - x[E_Table] := "00000,65535,00000" # green - x[E_Telem] := "00000,65535,00000" # green - x[E_Tvtbl] := "00000,65535,00000" # green - x[E_Slots] := "37448,00000,56172" # purple - x[E_Cset] := "65535,56172,00000" # yellow orange - - maps["qmscomb"] := x - -# Color map for rt.clr - - x := table() - - x[E_Coexpr] := "37448,28086,18724" # light brown - x[E_String] := "65535,65535,46810" # ivory - x[E_Tvsubs] := "65535,28086,56172" # pink - x[E_File] := "37448,00000,56172" # purple - x[E_Refresh] := "00000,00000,37448" # navy blue - x[E_Lrgint] := "65535,46810,28086" # peach - x[E_Real] := "65535,65535,00000" # yellow - x[E_Record] := "65535,37448,00000" # orange - x[E_Set] := "37448,00000,00000" # dark red - x[E_Selem] := "56172,00000,00000" # red - x[E_List] := "18724,46810,65535" # pastel blue - x[E_Lelem] := "09362,28086,46810" # medium blue - x[E_Table] := "00000,28086,00000" # dark green - x[E_Telem] := "00000,46810,00000" # medium green - x[E_Tvtbl] := "28086,65535,28086" # light green - x[E_Slots] := "37448,28086,18724" # light brown - x[E_Cset] := "46810,28086,00000" # reddish brown - - maps["rt"] := x - -# Color map for sun.clr - - x := table() - - x[E_Coexpr] := "37448,28086,18724" # light brown - x[E_String] := "65535,65535,46810" # ivory - x[E_Tvsubs] := "65535,28086,56172" # pink - x[E_File] := "37448,00000,56172" # purple - x[E_Refresh] := "00000,00000,37448" # navy blue - x[E_Lrgint] := "65535,46810,28086" # peach - x[E_Real] := "65535,65535,00000" # yellow - x[E_Record] := "65535,37448,00000" # orange - x[E_Set] := "46810,00000,00000" # dark red - x[E_Selem] := "56172,00000,00000" # red - x[E_List] := "18724,46810,65535" # pastel blue - x[E_Lelem] := "09362,28086,46810" # medium blue - x[E_Table] := "00000,28086,00000" # dark green - x[E_Telem] := "00000,37448,00000" # medium green - x[E_Tvtbl] := "00000,65535,00000" # light green - x[E_Slots] := "37448,28086,18724" # light brown - x[E_Cset] := "46810,28086,00000" # reddish brown - - maps["sun"] := x - -# Color map for standard colors - - x := table() - - x[E_Coexpr] := "deep gray" - x[E_String] := "pale yellow" - x[E_Tvsubs] := "yellow" - x[E_File] := "pale gray" - x[E_Refresh] := "deep gray" - x[E_Lrgint] := "pale brown" - x[E_Real] := "pale purple" - x[E_Record] := "magenta" - x[E_Set] := "dark red" - x[E_Selem] := "red" - x[E_List] := "dark blue green" - x[E_Lelem] := "blue green" - x[E_Table] := "dark green" - x[E_Telem] := "green" - x[E_Tvtbl] := "light green" - x[E_Slots] := "purple" - x[E_Cset] := "orange" - - maps["standard"] := x - } - - return \maps[\palette | "standard"] - -end diff --git a/ipl/mprocs/colortyp.icn b/ipl/mprocs/colortyp.icn deleted file mode 100644 index 2592e0f..0000000 --- a/ipl/mprocs/colortyp.icn +++ /dev/null @@ -1,44 +0,0 @@ -############################################################################ -# -# File: colortyp.icn -# -# Subject: Procedure to produce table of colors for Icon types -# -# Author: Ralph E. Griswold -# -# Date: July 1, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# Links: typecode -# -############################################################################ - -# Color table for Icon type codes - -procedure colortyp() - local x - - x := table() - - x["C"] := "deep gray" - x["s"] := "pale yellow" - x["r"] := "pale purple" - x["R"] := "magenta" - x["S"] := "dark red" - x["L"] := "dark blue green" - x["T"] := "dark green" - x["c"] := "orange" - x["f"] := "pink" - x["i"] := "white" - x["n"] := "gray" - x["p"] := "red viole" - x["w"] := "deep blue" - - return x - -end diff --git a/ipl/mprocs/em_setup.icn b/ipl/mprocs/em_setup.icn deleted file mode 100644 index c915fd8..0000000 --- a/ipl/mprocs/em_setup.icn +++ /dev/null @@ -1,101 +0,0 @@ -############################################################################ -# -# File: em_setup.icn -# -# Subject: Procedures to set up execution monitors -# -# Author: Ralph E. Griswold -# -# Date: March 3, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# These procedures provide support for the routine parts of building -# Icon execution monitors, including what's necessary for them to -# run stand-alone as well as under the control of monitor coordinators -# like eve and vc. -# -# vis_setup(args[]) opens a window with attributes given -# by args[] -# -# em_setup(sp) loads sp as the program to be monitored -# -# context_setup(mask) returns table of graphics context for -# mask -# -# prog_name() returns the name of the source program -# for the SP set up by em_setup() -# -# em_end() hold visualization window open if (a) -# there is one and (b) monitoring is -# stand alone -# -############################################################################ -# -# Requires: Version 9 MT Icon, instrumentation, and graphics -# -############################################################################ -# -# Links: evinit, interact, typebind, graphics -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link interact -link typebind -link graphics - -$include "evdefs.icn" - -global Coordination # if nonnull, vc is in charge -global Visualization # visualization window -global EventSource # vc's event source - -procedure vis_setup(args[]) #: set up visualization window - - Visualization := (WOpen ! args) | - stop("*** cannot open window for visualization") - - return Visualization - -end - -procedure em_setup(sp) #: set up program to be monitored - local trash - - trash := open("/dev/null", "w") | - stop("*** cannot open /dev/null") - - EvInit(sp, , trash, trash) | stop("*** cannot load SP") - - return - -end - -procedure context_setup(mask) #: table of graphics contexts for mask - - return typebind(Visualization, mask) - -end - -procedure prog_name() #: name of monitored source program - - return variable("&progname", EventSource) || ".icn" - -end - -procedure em_end() #: hold event monitoring for event at end - local back - - back := WOpen("canvas=hidden", "bg=light gray") - if /Coordination then ExitNotice(back, "Normal termination of SP") - -end diff --git a/ipl/mprocs/emutils.icn b/ipl/mprocs/emutils.icn deleted file mode 100644 index 322815f..0000000 --- a/ipl/mprocs/emutils.icn +++ /dev/null @@ -1,508 +0,0 @@ -############################################################################ -# -# File: emutils.icn -# -# Subject: Procedures to support MT-Icon monitors -# -# Author: Ralph E. Griswold -# -# Date: April 16, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# evname(s) maps the event code to a standard descriptive phrases and vice -# versa. -# -############################################################################ -# -# Links: convert, tables -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link convert -link tables - -$include "evdefs.icn" - -procedure evname(s) - local result - static namemap - - initial { - namemap := table() - - namemap[E_Aconv] := "conversion attempt" - namemap[E_Argp] := "argument pointer" - namemap[E_Alien] := "alien allocation" - namemap[E_Assign] := "assignment" -# namemap[E_Base] := "base address of storage region" - namemap[E_BlkDeAlc] := "block deallocation" - namemap[E_Bsusp] := "suspension from operation" - namemap[E_Coact] := "co-expression activation" - namemap[E_Cocreate] := "co-expression creation" - namemap[E_Coexpr] := "co-expression allocation" - namemap[E_Cofail] := "co-expression failure" - namemap[E_Collect] := "garbage collection" -# namemap[E_Comment] := "comment" - namemap[E_Coret] := "co-expression return" - namemap[E_Cset] := "cset allocation" - namemap[E_Deref] := "variable dereference" - namemap[E_Ecall] := "call of operation" - namemap[E_Efail] := "failure from expression" - namemap[E_Efp] := "expression frame pointer" - namemap[E_EndCollect] := "end of garbage collection" - namemap[E_Erem] := "removal of a suspended generator" - namemap[E_Eresum] := "resumption of expression" -# namemap[E_Eret] := "return from expression" - namemap[E_Error] := "run-time error" - namemap[E_Esusp] := "suspension from alternation" - namemap[E_Exit] := "program exit" - namemap[E_External] := "external allocation" - namemap[E_Fcall] := "function call" - namemap[E_Fclose] := "file close" - namemap[E_Fconv] := "conversion failure" - namemap[E_Ffail] := "function failure" - namemap[E_File] := "file allocation" - namemap[E_Floc] := "file location" - namemap[E_Fmode] := "file open mode" - namemap[E_Fopen] := "file open" - namemap[E_Fread] := "file read" - namemap[E_Freads] := "file reads" - namemap[E_Free] := "free region" - namemap[E_Frem] := "function suspension removal" - namemap[E_Fresum] := "function resumption" - namemap[E_Fret] := "function return" - namemap[E_Fseek] := "file seek" - namemap[E_Fstring] := "string read or written" - namemap[E_Fsusp] := "function suspension" - namemap[E_Fwhere] := "file location" - namemap[E_Fwrite] := "function write" - namemap["\223"] := "function writes" - namemap[E_Gfp] := "generator frame pointer" -# namemap[E_Highlight] := "allocation highlight" - namemap[E_Ilevel] := "interpreter call level" - namemap[E_Intcall] := "interpreter call" - namemap[E_Integer] := "integer value pseudo-event" - namemap[E_Intret] := "interpreter return" - namemap[E_Ipc] := "interpreter program counter" - namemap[E_Kywdint] := "integer keyword value pseudo-event" - namemap[E_Kywdpos] := "position value pseudo-event" - namemap[E_Kywdsubj] := "subject value pseudo-event" - namemap[E_Lbang] := "list generation" - namemap[E_Lcreate] := "list creation" - namemap[E_Lelem] := "list element allocation" - namemap[E_Lget] := "list get" - namemap[E_Line] := "line change" - namemap[E_List] := "list allocation" - namemap[E_Loc] := "location change" - namemap[E_Lpop] := "list pop" - namemap[E_Lpull] := "list pull" - namemap[E_Lpush] := "list push" - namemap[E_Lput] := "list put" - namemap[E_Lrand] := "list random reference" -# namemap[E_Lref] := "list reference" - namemap[E_Lrgint] := "large integer allocation" - namemap[E_Lsub] := "list subscript" - namemap[E_Lsusp] := "suspension from limitation" - namemap[E_MXevent] := "monitor input event" - namemap[E_Nconv] := "conversion not needed" - namemap[E_NewRegion] := "new storage region" - namemap[E_Null] := "null value value pseudo-event" - namemap[E_Ocall] := "operator call" - namemap[E_Ofail] := "operator failure" -# namemap[E_Offset] := "address offset" -# namemap[E_Op] := "interpreter operation" - namemap[E_Opcode] := "virtual-machine instruction" - namemap[E_Orem] := "operator suspension removal" - namemap[E_Oresum] := "operator resumption" - namemap[E_Oret] := "operator return" - namemap[E_Osusp] := "operator suspension" -# namemap[E_Pause] := "memory monitoring comment" - namemap[E_Pcall] := "procedure call" - namemap[E_Pfail] := "procedure failure" - namemap[E_Pfp] := "procedure frame pointer" -# namemap[E_Pid] := "symbol name" - namemap[E_Prem] := "suspended procedure removal" - namemap[E_Presum] := "procedure resumption" - namemap[E_Pret] := "procedure return" - namemap[E_Proc] := "procedure value pseudo-event" - namemap[E_Psusp] := "procedure suspension" - namemap[E_Rbang] := "record generation" - namemap[E_Rcreate] := "record creation" - namemap[E_Real] := "real allocation" - namemap[E_Record] := "record allocation" - namemap[E_Refresh] := "refresh allocation" -# namemap[E_Region] := "region" - namemap[E_Rrand] := "record random reference" -# namemap[E_Rref] := "record reference" - namemap[E_Rsub] := "record subscript" - namemap[E_Sbang] := "set generation" - namemap[E_Sconv] := "conversion success" - namemap[E_Screate] := "set creation" - namemap[E_Sdelete] := "set deletion" - namemap[E_Selem] := "set element allocation" - namemap[E_Set] := "set allocation" - namemap[E_Sfail] := "scanning failure" - namemap[E_Sinsert] := "set insertion" -# namemap[E_Size] := "region size" - namemap[E_Slots] := "hash header allocation" - namemap[E_Smember] := "set membership" - namemap[E_Snew] := "scanning environment creation" - namemap[E_Spos] := "scanning position" - namemap[E_Srand] := "set random reference" - namemap[E_Srem] := "scanning environment removal" - namemap[E_Sresum] := "scanning resumption" - namemap[E_Ssasgn] := "substring assignment" - namemap[E_Ssusp] := "scanning suspension" - namemap[E_Stack] := "stack depth" - namemap[E_StrDeAlc] := "string deallocation" - namemap[E_String] := "string allocation" - namemap[E_Sval] := "set value" -# namemap[E_Sym] := "symbol table entry" - namemap[E_Table] := "table allocation" - namemap[E_Tbang] := "table generation" - namemap[E_Tconv] := "conversion target" - namemap[E_Tcreate] := "table creation" - namemap[E_Tdelete] := "table deletion" - namemap[E_Telem] := "table element allocation" - namemap[E_TenureBlock] := "tenure a block region" - namemap[E_TenureString] := "tenure a string region" - namemap[E_Tick] := "clock tick" - namemap[E_Tinsert] := "table insertion" - namemap[E_Tkey] := "table key generation" - namemap[E_Tmember] := "table membership" - namemap[E_Trand] := "table random reference" -# namemap[E_Tref] := "table reference" - namemap[E_Tsub] := "table subscript" -# namemap[E_Tval] := "table value" - namemap[E_Tvsubs] := "substring trapped variable allocation" - namemap[E_Tvtbl] := "table-element trapped variable allocation" -# namemap[E_Used] := "space used" - namemap[E_Value] := "value assigned" - namemap[E_Fterm] := "write terminator" - -# namemap := twt(namemap) - } - - result := namemap[s] - /result := "E_\\" || exbase10(find(s, &cset) - 1, 8) - - return result - -end - -############################################################################ -# -# evsym() maps event codes to the symbolic names for the codes and vice -# versa. -# -############################################################################ - -procedure evsym(s) - local result - static symmap - - initial { - symmap := table() - - symmap[E_Aconv] := "E_Aconv" - symmap[E_Argp] := "E_Argp" - symmap[E_Alien] := "E_Alien" - symmap[E_Assign] := "E_Assign" - symmap[E_BlkDeAlc] := "E_BlkDeAlc" - symmap[E_Bsusp] := "E_Bsusp" - symmap[E_Coact] := "E_Coact" - symmap[E_Cocreate] := "E_Cocreate" - symmap[E_Coexpr] := "E_Coexpr" - symmap[E_Cofail] := "E_Cofail" - symmap[E_Cofree] := "E_Cofree" - symmap[E_Collect] := "E_Collect" - symmap[E_Coret] := "E_Coret" - symmap[E_Cset] := "E_Cset" - symmap[E_Deref] := "E_Deref" - symmap[E_Ecall] := "E_Ecall" - symmap[E_Efail] := "E_Efail" - symmap[E_Efp] := "E_Efp" - symmap[E_Eresum] := "E_Eresum" - symmap[E_Error] := "E_Error" - symmap[E_Esusp] := "E_Esusp" - symmap[E_Erem] := "E_Erem" - symmap[E_Exit] := "E_Exit" - symmap[E_External] := "E_External" - symmap[E_Fcall] := "E_Fcall" - symmap[E_Fclose] := "E_Fclose" - symmap[E_Fconv] := "E_Fconv" - symmap[E_Ffail] := "E_Ffail" - symmap[E_File] := "E_File" - symmap[E_Floc] := "E_Loc" - symmap[E_Fmode] := "E_Fmode" - symmap[E_Fopen] := "E_Fopen" - symmap[E_Fread] := "E_Fread" - symmap[E_Freads] := "E_Freads" - symmap[E_Free] := "E_Free" - symmap[E_Frem] := "E_Frem" - symmap[E_Fresum] := "E_Fresum" - symmap[E_Fret] := "E_Fret" - symmap[E_Fseek] := "E_Fseek" - symmap[E_Fstring] := "E_Fstring" - symmap[E_Fsusp] := "E_Fsusp" - symmap[E_Fwhere] := "E_Fwhere" - symmap[E_Fwrite] := "E_Fwrite" - symmap[E_Fterm] := "E_Fterm" - symmap[E_Gfp] := "E_Gfp" - symmap[E_Ilevel] := "E_Ilevel" - symmap[E_Intcall] := "E_Intcall" - symmap[E_Integer] := "E_Integer" - symmap[E_Intret] := "E_Intret" - symmap[E_Ipc] := "E_Ipc" - symmap[E_Kywdint] := "E_Kywdint" - symmap[E_Kywdpos] := "E_Kywdpos" - symmap[E_Kywdsubj] := "E_Kywdsubj" - symmap[E_Lbang] := "E_Lbang" - symmap[E_Lcreate] := "E_Lcreate" - symmap[E_Lelem] := "E_Lelem" - symmap[E_Line] := "E_Line" - symmap[E_List] := "E_List" - symmap[E_Loc] := "E_Loc" - symmap[E_Lpop] := "E_Lpop" - symmap[E_Lpull] := "E_Lpull" - symmap[E_Lpush] := "E_Lpush" - symmap[E_Lput] := "E_Lput" - symmap[E_Lrand] := "E_Lrand" - symmap[E_Lref] := "E_Lref" - symmap[E_Lrgint] := "E_Lrgint" - symmap[E_Lsub] := "E_Lsub" - symmap[E_Lsusp] := "E_Lsusp" - symmap[E_Nconv] := "E_Nconv" - symmap[E_NewRegion]:= "E_NewRegion" - symmap[E_Null] := "E_Null" - symmap[E_Ocall] := "E_Ocall" - symmap[E_Ofail] := "E_Ofail" - symmap[E_Op] := "E_Op" - symmap[E_Opcode] := "E_Opcode" - symmap[E_Oresum] := "E_Oresum" - symmap[E_Oret] := "E_Oret" - symmap[E_Osusp] := "E_Osusp" - symmap[E_Orem] := "E_Orem" - symmap[E_Pcall] := "E_Pcall" - symmap[E_Pfail] := "E_Pfail" - symmap[E_Pfp] := "E_Pfp" - symmap[E_Presum] := "E_Presum" - symmap[E_Pret] := "E_Pret" - symmap[E_Proc] := "E_Proc" - symmap[E_Psusp] := "E_Psusp" - symmap[E_Prem] := "E_Prem" - symmap[E_Rbang] := "E_Rbang" - symmap[E_Rcreate] := "E_Rcreate" - symmap[E_Real] := "E_Real" - symmap[E_Record] := "E_Record" - symmap[E_Refresh] := "E_Refresh" - symmap[E_Rrand] := "E_Rrand" - symmap[E_Rref] := "E_Rref" - symmap[E_Rsub] := "E_Rsub" - symmap[E_Sbang] := "E_Sbang" - symmap[E_Sconv] := "E_Sconv" - symmap[E_Screate] := "E_Screate" - symmap[E_Sdelete] := "E_Sdelete" - symmap[E_Selem] := "E_Selem" - symmap[E_Set] := "E_Set" - symmap[E_Sfail] := "E_Sfail" - symmap[E_Sinsert] := "E_Sinsert" - symmap[E_Slots] := "E_Slots" - symmap[E_Smember] := "E_Smember" - symmap[E_Snew] := "E_Snew" - symmap[E_Spos] := "E_Spos" - symmap[E_Srand] := "E_Srand" - symmap[E_Sresum] := "E_Sresum" - symmap[E_Ssasgn] := "E_Ssasgn" - symmap[E_Ssusp] := "E_Ssusp" - symmap[E_Stack] := "E_Stack" - symmap[E_StrDeAlc] := "E_StrDeAlc" - symmap[E_String] := "E_String" - symmap[E_Sval] := "E_Sval" - symmap[E_Srem] := "E_Srem" - symmap[E_Table] := "E_Table" - symmap[E_Tbang] := "E_Tbang" - symmap[E_Tconv] := "E_Tconv" - symmap[E_Tcreate] := "E_Tcreate" - symmap[E_Tdelete] := "E_Tdelete" - symmap[E_Telem] := "E_Telem" - symmap[E_Tick] := "E_Tick" - symmap[E_Tinsert] := "E_Tinsert" - symmap[E_Tkey] := "E_Tkey" - symmap[E_Tmember] := "E_Tmember" - symmap[E_Trand] := "E_Trand" - symmap[E_Tref] := "E_Tref" - symmap[E_Tsub] := "E_Tsub" - symmap[E_Tval] := "E_Tval" - symmap[E_Tvsubs] := "E_Tvsubs" - symmap[E_Tvtbl] := "E_Tvtbl" - symmap[E_Value] := "E_Value" - - twt(symmap) - } - - result := symmap[s] - /result := "E_\\" || exbase10(find(s, &cset), 8) - - return result - -end - -procedure allocode(s) - static allocmap - - initial { - allocmap := table("unknown code") - - allocmap[E_Coexpr] := "co-expression" - allocmap[E_Cset] := "cset" - allocmap[E_File] := "file" - allocmap[E_List] := "list" - allocmap[E_Real] := "real" - allocmap[E_Record] := "record" - allocmap[E_Set] := "set" - allocmap[E_String] := "string" - allocmap[E_Table] := "table" - - twt(allocmap) - } - - return allocmap[s] - -end - -# Turn off output in SP. - -procedure kill_output() - - variable("write", EventSource) := -1 - variable("writes", EventSource) := -1 - - return - -end - -############################################################################ -# -# opname() maps a virtual-machine instruction number to a symbolic name. -# -############################################################################ - -procedure opname(i) #: map virtual-machine code to name - static opmap - - initial { - opmap := table("") - - opmap[1] := "Asgn" - opmap[2] := "Bang" - opmap[3] := "Cat" - opmap[4] := "Compl" - opmap[5] := "Diff" - opmap[6] := "Div" - opmap[7] := "Eqv" - opmap[8] := "Inter" - opmap[9] := "Lconcat" - opmap[10] := "Lexeq" - opmap[11] := "Lexge" - opmap[12] := "Lexgt" - opmap[13] := "Lexle" - opmap[14] := "Lexlt" - opmap[15] := "Lexne" - opmap[16] := "Minus" - opmap[17] := "Mod" - opmap[18] := "Mult" - opmap[19] := "Neg" - opmap[20] := "Neqv" - opmap[21] := "Nonnull" - opmap[22] := "Null" - opmap[23] := "Number" - opmap[24] := "Numeq" - opmap[25] := "Numge" - opmap[26] := "Numgt" - opmap[27] := "Numle" - opmap[28] := "Numlt" - opmap[29] := "Numne" - opmap[30] := "Plus" - opmap[31] := "Power" - opmap[32] := "Random" - opmap[33] := "Rasgn" - opmap[34] := "Refresh" - opmap[35] := "Rswap" - opmap[36] := "Sect" - opmap[37] := "Size" - opmap[38] := "Subsc" - opmap[39] := "Swap" - opmap[40] := "Tabmat" - opmap[41] := "Toby" - opmap[42] := "Unions" - opmap[43] := "Value" - opmap[44] := "Bscan" - opmap[45] := "Ccase" - opmap[46] := "Chfail" - opmap[47] := "Coact" - opmap[48] := "Cofail" - opmap[49] := "Coret" - opmap[50] := "Create" - opmap[51] := "Cset" - opmap[52] := "Dup" - opmap[53] := "Efail" - opmap[54] := "Eret" - opmap[55] := "Escan" - opmap[56] := "Esusp" - opmap[57] := "Field" - opmap[58] := "Goto" - opmap[59] := "Init" - opmap[60] := "Int" - opmap[61] := "Invoke" - opmap[62] := "Keywd" - opmap[63] := "Limit" - opmap[64] := "Line" - opmap[65] := "Llist" - opmap[66] := "Lsusp" - opmap[67] := "Mark" - opmap[68] := "Pfail" - opmap[69] := "Pnull" - opmap[70] := "Pop" - opmap[71] := "Pret" - opmap[72] := "Psusp" - opmap[73] := "Push1" - opmap[74] := "Pushn1" - opmap[75] := "Real" - opmap[76] := "Sdup" - opmap[77] := "Str" - opmap[78] := "Unmark" - opmap[80] := "Var" - opmap[81] := "Arg" - opmap[82] := "Static" - opmap[83] := "Local" - opmap[84] := "Global" - opmap[85] := "Mark0" - opmap[86] := "Quit" - opmap[87] := "FQuit" - opmap[88] := "Tally" - opmap[89] := "Apply" - opmap[90] := "Acset" - opmap[91] := "Areal" - opmap[92] := "Astr" - opmap[93] := "Aglobal" - opmap[94] := "Astatic" - opmap[95] := "Agoto" - opmap[96] := "Amark" - opmap[98] := "Noop" - opmap[100] := "SymEvents" - opmap[108] := "Colm" - } - - return opmap[i] - -end diff --git a/ipl/mprocs/evaltree.icn b/ipl/mprocs/evaltree.icn deleted file mode 100644 index c007dca..0000000 --- a/ipl/mprocs/evaltree.icn +++ /dev/null @@ -1,106 +0,0 @@ -############################################################################ -# -# File: evaltree.icn -# -# Subject: Procedures to maintain activation tree -# -# Author: Clinton Jeffery -# -# Date: June 19, 1994 -# -########################################################################### -# -# This file is in the public domain. -# -############################################################################ -# -# Usage: evaltree(cset, procedure, record constructor) -# -# The record type must have fields node, parent, children -# -# See "A Framework for Monitoring Program Execution", Clinton L. Jeffery, -# TR 93-21, Department of Computer Science, The University of Arizona, -# July 30, 1993. -# -############################################################################ -# -# Requires: MT Icon and event monitoring -# -############################################################################ - -$include "evdefs.icn" - -record __evaltree_node(node,parent,children) - -global CallCodes, - SuspendCodes, - ResumeCodes, - ReturnCodes, - FailCodes, - RemoveCodes - -procedure evaltree(mask, callback, activation_record) - local c, current, p, child - - - /activation_record := __evaltree_node - CallCodes := string(mask ** cset(E_Pcall || E_Fcall || E_Ocall || E_Snew)) - SuspendCodes := string(mask ** cset(E_Psusp || E_Fsusp || - E_Osusp || E_Ssusp)) - ResumeCodes := string(mask ** cset(E_Presum || E_Fresum || E_Oresum || - E_Sresum)) - ReturnCodes := string(mask ** cset(E_Pret || E_Fret || E_Oret)) - FailCodes := string(mask ** cset(E_Pfail || E_Ffail || E_Ofail || E_Sfail)) - RemoveCodes := string(mask ** cset(E_Prem || E_Frem || E_Orem || E_Srem)) - - current := activation_record() - current.parent := activation_record() - current.children := [] - current.parent.children := [] - - while EvGet(mask) do { - case &eventcode of { - !CallCodes: { - c := activation_record() - c.node := &eventvalue - c.parent := current - c.children := [] - put(current.children, c) - current := c - callback(current, current.parent) - } - !ReturnCodes | !FailCodes: { - p := pull(current.parent.children) - current := current.parent - callback(current, p) - } - !SuspendCodes: { - current := current.parent - callback(current, current.children[-1]) - } - !ResumeCodes: { - current := current.children[-1] - callback(current, current.parent) - } - !RemoveCodes: { - if child := pull(current.children) then { - while put(current.children, pop(child.children)) - callback(current, child) - } - else { - if current === current.parent.children[-1] then { - p := pull(current.parent.children) - current := current.parent - callback(current, p) - next - } - else stop("evaltree: unknown removal") - } - } - default: { - callback(current, current) - } - } - } -end - diff --git a/ipl/mprocs/evinit.icn b/ipl/mprocs/evinit.icn deleted file mode 100644 index 09a2ee6..0000000 --- a/ipl/mprocs/evinit.icn +++ /dev/null @@ -1,89 +0,0 @@ -############################################################################ -# -# File: evinit.icn -# -# Subject: Procedures for event monitoring -# -# Author: Ralph E. Griswold -# -# Date: November 5, 1995 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This file provides initialization for event monitors. -# -# This file is intended for use with event monitors running under -# MT Icon. -# -############################################################################ - -$include "evdefs.icn" - -procedure EvInit(f,input,output,error) - if not MTEvInit(f,input,output,error) then fail - return -end - -procedure EvTerm(win) - if &eventsource === (Monitored | EventSource) then { - if type(win) == "window" then - Event(win) - } -end -# -# MultiThread EventMon support, from file mtsupport.icn -# - -global Monitored, EventSource, MTEventMask - -# -# If EvInit is called with a string or a list, run as a standalone MT-based -# event monitor -- load the icode file and overload certain EvMon symbols. -# -# This operation is skipped if &eventsource has already been initialized, -# presumably by some event broker such as Eve. -# -procedure MTEvInit(f,input,output,error) - - if \&eventsource then return - - if type(f) == "string" then { - &eventsource := EventSource := Monitored := load(f,,input,output,error) | fail - EvGet :=: MTEvGet - } - else if type(f) == "list" then { - &eventsource := EventSource := Monitored := load(f[1],f[2:0],input,output,error) | fail - EvGet :=: MTEvGet - } - return &eventsource -end - -procedure MTEvGet(c,flag) - static lastcset - initial { - lastcset := '' - } - - if c ~=== lastcset then { - lastcset := c - eventmask(\(Monitored | EventSource) ,\c | &cset,&main) - } - return MTEvGet(c,flag) -end - -# -# Eve-specific extensions to the general model -# -procedure EvQuit() - EvSignal("quit") -end - -procedure EvSignal(x) - if type(x) == "cset" then - write(&errout, "EvSignal(", image(x), ") is ambiguous.") - return x @ &eventsource -end diff --git a/ipl/mprocs/evnames.icn b/ipl/mprocs/evnames.icn deleted file mode 100644 index 046b4a3..0000000 --- a/ipl/mprocs/evnames.icn +++ /dev/null @@ -1,174 +0,0 @@ -############################################################################ -# -# File: evnames.icn -# -# Subject: Procedures to map between event codes and names -# -# Author: Ralph E. Griswold -# -# Date: December 26, 1995 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# evnames(x) creates a two-way table. Indexed by an event code, it -# produces a descriptive phrase for the code. Indexed by the descriptive -# phrase it produces the event code. It returns the value for key x. -# -############################################################################ -# -# Links: tables -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link tables - -$include "evdefs.icn" - -procedure evnames(e) - static namemap - - initial { - namemap := table("unknown event") - - namemap[E_Aconv] := "conversion attempt" - namemap[E_Alien] := "alien allocation" - namemap[E_Assign] := "assignment" - namemap[E_Base] := "base address of storage region" - namemap[E_BlkDeAlc] := "block deallocation" - namemap[E_Bsusp] := "suspension from operation" - namemap[E_Coact] := "co-expression activation" - namemap[E_Coexpr] := "co-expression allocation" - namemap[E_Cofail] := "co-expression failure" - namemap[E_Collect] := "garbage collection" - namemap[E_Comment] := "comment" - namemap[E_Coret] := "co-expression return" - namemap[E_Cset] := "cset allocation" - namemap[E_Ecall] := "call of operation" - namemap[E_Efail] := "failure from expression" - namemap[E_EndCollect] := "end of garbage collection" - namemap[E_Erem] := "removal of a suspended generator" - namemap[E_Eresum] := "resumption of expression" - namemap[E_Eret] := "return from expression" - namemap[E_Error] := "run-time error" - namemap[E_Esusp] := "suspension from alternation" - namemap[E_Exit] := "program exit" - namemap[E_External] := "external allocation" - namemap[E_Fcall] := "function call" - namemap[E_Fconv] := "conversion failure" - namemap[E_Ffail] := "function failure" - namemap[E_File] := "file allocation" - namemap[E_Free] := "free region" - namemap[E_Frem] := "function suspension removal" - namemap[E_Fresum] := "function resumption" - namemap[E_Fret] := "function return" - namemap[E_Fsusp] := "function suspension" - namemap[E_Highlight] := "allocation highlight" - namemap[E_Intcall] := "interpreter call" - namemap[E_Integer] := "integer value pseudo-event" - namemap[E_Intret] := "interpreter return" - namemap[E_Kywdint] := "integer keyword value pseudo-event" - namemap[E_Kywdpos] := "position value pseudo-event" - namemap[E_Kywdsubj] := "subject value pseudo-event" - namemap[E_Lbang] := "list generation" - namemap[E_Lcreate] := "list creation" - namemap[E_Lelem] := "list element allocation" - namemap[E_Lget] := "list get" - namemap[E_Line] := "line change" - namemap[E_List] := "list allocation" - namemap[E_Loc] := "location change" - namemap[E_Lpop] := "list pop" - namemap[E_Lpull] := "list pull" - namemap[E_Lpush] := "list push" - namemap[E_Lput] := "list put" - namemap[E_Lrand] := "list random reference" - namemap[E_Lref] := "list reference" - namemap[E_Lrgint] := "large integer allocation" - namemap[E_Lsub] := "list subscript" - namemap[E_Lsusp] := "suspension from limitation" - namemap[E_MXevent] := "monitor input event" - namemap[E_Nconv] := "conversion not needed" - namemap[E_Null] := "null value value pseudo-event" - namemap[E_Ocall] := "operator call" - namemap[E_Ofail] := "operator failure" - namemap[E_Offset] := "address offset" - namemap[E_Opcode] := "virtual-machine instruction" - namemap[E_Orem] := "operator suspension removal" - namemap[E_Oresum] := "operator resumption" - namemap[E_Oret] := "operator return" - namemap[E_Osusp] := "operator suspension" - namemap[E_Pause] := "memory monitoring comment" - namemap[E_Pcall] := "procedure call" - namemap[E_Pfail] := "procedure failure" - namemap[E_Pid] := "symbol name" - namemap[E_Prem] := "suspended procedure removal" - namemap[E_Presum] := "procedure resumption" - namemap[E_Pret] := "procedure return" - namemap[E_Proc] := "procedure value pseudo-event" - namemap[E_Psusp] := "procedure suspension" - namemap[E_Rbang] := "record generation" - namemap[E_Rcreate] := "record creation" - namemap[E_Real] := "real allocation" - namemap[E_Record] := "record allocation" - namemap[E_Refresh] := "refresh allocation" - namemap[E_Region] := "region" - namemap[E_Rrand] := "record random reference" - namemap[E_Rref] := "record reference" - namemap[E_Rsub] := "record subscript" - namemap[E_Sbang] := "set generation" - namemap[E_Sconv] := "conversion success" - namemap[E_Screate] := "set creation" - namemap[E_Sdelete] := "set deletion" - namemap[E_Selem] := "set element allocation" - namemap[E_Set] := "set allocation" - namemap[E_Sfail] := "scanning failure" - namemap[E_Sinsert] := "set insertion" - namemap[E_Size] := "region size" - namemap[E_Slots] := "hash header allocation" - namemap[E_Smember] := "set membership" - namemap[E_Snew] := "scanning environment creation" - namemap[E_Spos] := "scanning position" - namemap[E_Srand] := "set random reference" - namemap[E_Srem] := "scanning environment removal" - namemap[E_Sresum] := "scanning resumption" - namemap[E_Ssasgn] := "substring assignment" - namemap[E_Ssusp] := "scanning suspension" - namemap[E_Stack] := "stack depth" - namemap[E_StrDeAlc] := "string deallocation" - namemap[E_String] := "string allocation" - namemap[E_Sval] := "set value" - namemap[E_Sym] := "symbol table entry" - namemap[E_Table] := "table allocation" - namemap[E_Tbang] := "table generation" - namemap[E_Tconv] := "conversion target" - namemap[E_Tcreate] := "table creation" - namemap[E_Tdelete] := "table deletion" - namemap[E_Telem] := "table element allocation" - namemap[E_TenureBlock] := "tenure a block region" - namemap[E_TenureString] := "tenure a string region" - namemap[E_Tick] := "clock tick" - namemap[E_Tinsert] := "table insertion" - namemap[E_Tkey] := "table key generation" - namemap[E_Tmember] := "table membership" - namemap[E_Trand] := "table random reference" - namemap[E_Tref] := "table reference" - namemap[E_Tsub] := "table subscript" - namemap[E_Tval] := "table value" - namemap[E_Tvsubs] := "substring trapped variable allocation" - namemap[E_Tvtbl] := "table-element trapped variable allocation" - namemap[E_Used] := "space used" - namemap[E_Value] := "value assigned" - - twt(namemap) - } - - return namemap[e] - -end diff --git a/ipl/mprocs/evsyms.icn b/ipl/mprocs/evsyms.icn deleted file mode 100644 index 8ccc705..0000000 --- a/ipl/mprocs/evsyms.icn +++ /dev/null @@ -1,160 +0,0 @@ -############################################################################ -# -# File: evsyms.icn -# -# Subject: Procedures to produce table of event codes and symbols -# -# Author: Ralph E. Griswold -# -# Date: October 3, 1996 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# evsyms() returns returns a two-way table. Indexed by an event code, it -# produces the symbol (global identifier name) for the code. Indexed by the -# symbol of the code, it produces the event code. -# -# This procedure is intended for use in event monitors under MT Icon. -# -############################################################################ -# -# Links: tables -# -############################################################################ -# -# Includes: "evdefs.icn" -# -############################################################################ - -link tables - -$include "evdefs.icn" - -procedure evsyms() - static symmap - - initial { - symmap := table("E_????") - - symmap[E_Aconv] := "E_Aconv" - symmap[E_Alien] := "E_Alien" - symmap[E_Assign] := "E_Assign" - symmap[E_BlkDeAlc] := "E_BlkDeAlc" - symmap[E_Bsusp] := "E_Bsusp" - symmap[E_Coact] := "E_Coact" - symmap[E_Coexpr] := "E_Coexpr" - symmap[E_Cofail] := "E_Cofail" - symmap[E_Collect] := "E_Collect" - symmap[E_Coret] := "E_Coret" - symmap[E_Cset] := "E_Cset" - symmap[E_Ecall] := "E_Ecall" - symmap[E_Efail] := "E_Efail" - symmap[E_Eresum] := "E_Eresum" - symmap[E_Error] := "E_Error" - symmap[E_Esusp] := "E_Esusp" - symmap[E_Erem] := "E_Erem" - symmap[E_Exit] := "E_Exit" - symmap[E_External] := "E_External" - symmap[E_Fcall] := "E_Fcall" - symmap[E_Fconv] := "E_Fconv" - symmap[E_Ffail] := "E_Ffail" - symmap[E_File] := "E_File" - symmap[E_Free] := "E_Free" - symmap[E_Fresum] := "E_Fresum" - symmap[E_Fret] := "E_Fret" - symmap[E_Fsusp] := "E_Fsusp" - symmap[E_Frem] := "E_Frem" - symmap[E_Intcall] := "E_Intcall" - symmap[E_Integer] := "E_Integer" - symmap[E_Intret] := "E_Intret" - symmap[E_Kywdint] := "E_Kywdint" - symmap[E_Kywdpos] := "E_Kywdpos" - symmap[E_Kywdsubj] := "E_Kywdsubj" - symmap[E_Lbang] := "E_Lbang" - symmap[E_Lcreate] := "E_Lcreate" - symmap[E_Lelem] := "E_Lelem" - symmap[E_Line] := "E_Line" - symmap[E_List] := "E_List" - symmap[E_Loc] := "E_Loc" - symmap[E_Lpop] := "E_Lpop" - symmap[E_Lpull] := "E_Lpull" - symmap[E_Lpush] := "E_Lpush" - symmap[E_Lput] := "E_Lput" - symmap[E_Lrand] := "E_Lrand" - symmap[E_Lref] := "E_Lref" - symmap[E_Lrgint] := "E_Lrgint" - symmap[E_Lsub] := "E_Lsub" - symmap[E_Lsusp] := "E_Lsusp" - symmap[E_Nconv] := "E_Nconv" - symmap[E_Null] := "E_Null" - symmap[E_Ocall] := "E_Ocall" - symmap[E_Ofail] := "E_Ofail" - symmap[E_Opcode] := "E_Opcode" - symmap[E_Oresum] := "E_Oresum" - symmap[E_Oret] := "E_Oret" - symmap[E_Osusp] := "E_Osusp" - symmap[E_Orem] := "E_Orem" - symmap[E_Pcall] := "E_Pcall" - symmap[E_Pfail] := "E_Pfail" - symmap[E_Presum] := "E_Presum" - symmap[E_Pret] := "E_Pret" - symmap[E_Proc] := "E_Proc" - symmap[E_Psusp] := "E_Psusp" - symmap[E_Prem] := "E_Prem" - symmap[E_Rbang] := "E_Rbang" - symmap[E_Rcreate] := "E_Rcreate" - symmap[E_Real] := "E_Real" - symmap[E_Record] := "E_Record" - symmap[E_Refresh] := "E_Refresh" - symmap[E_Rrand] := "E_Rrand" - symmap[E_Rref] := "E_Rref" - symmap[E_Rsub] := "E_Rsub" - symmap[E_Sbang] := "E_Sbang" - symmap[E_Sconv] := "E_Sconv" - symmap[E_Screate] := "E_Screate" - symmap[E_Sdelete] := "E_Sdelete" - symmap[E_Selem] := "E_Selem" - symmap[E_Set] := "E_Set" - symmap[E_Sfail] := "E_Sfail" - symmap[E_Sinsert] := "E_Sinsert" - symmap[E_Slots] := "E_Slots" - symmap[E_Smember] := "E_Smember" - symmap[E_Snew] := "E_Snew" - symmap[E_Spos] := "E_Spos" - symmap[E_Srand] := "E_Srand" - symmap[E_Sresum] := "E_Sresum" - symmap[E_Ssasgn] := "E_Ssasgn" - symmap[E_Ssusp] := "E_Ssusp" - symmap[E_Stack] := "E_Stack" - symmap[E_StrDeAlc] := "E_StrDeAlc" - symmap[E_String] := "E_String" - symmap[E_Sval] := "E_Sval" - symmap[E_Srem] := "E_Srem" - symmap[E_Table] := "E_Table" - symmap[E_Tbang] := "E_Tbang" - symmap[E_Tconv] := "E_Tconv" - symmap[E_Tcreate] := "E_Tcreate" - symmap[E_Tdelete] := "E_Tdelete" - symmap[E_Telem] := "E_Telem" - symmap[E_Tick] := "E_Tick" - symmap[E_Tinsert] := "E_Tinsert" - symmap[E_Tkey] := "E_Tkey" - symmap[E_Tmember] := "E_Tmember" - symmap[E_Trand] := "E_Trand" - symmap[E_Tref] := "E_Tref" - symmap[E_Tsub] := "E_Tsub" - symmap[E_Tval] := "E_Tval" - symmap[E_Tvsubs] := "E_Tvsubs" - symmap[E_Tvtbl] := "E_Tvtbl" - symmap[E_Value] := "E_Value" - - symmap := twt(symmap) - } - - return symmap - -end diff --git a/ipl/mprocs/evtmap.icn b/ipl/mprocs/evtmap.icn deleted file mode 100644 index 255adae..0000000 --- a/ipl/mprocs/evtmap.icn +++ /dev/null @@ -1,181 +0,0 @@ -############################################################################ -# -# File: evtmap.icn -# -# Subject: Procedure to map event code names to values -# -# Author: Ralph E. Griswold -# -# Date: July 15, 1995 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# evtmap(s) returns the event-code value for the event string name s. It -# fails is s is not the name of an event value. -# -############################################################################ -# -# Includes: evdefs.icn, etdefs.icn -# -############################################################################ - -$include "evdefs.icn" -$include "etdefs.icn" - -procedure evtmap(s) #: map event code name to event value - static maptbl - - initial { - maptbl:= table() - - maptbl["E_Aconv"] := "I" - maptbl["E_Alien"] := "z" - maptbl["E_Assign"] := "\347" - maptbl["E_Base"] := "<" - maptbl["E_BlkDeAlc"] := "-" - maptbl["E_Bsusp"] := "b" - maptbl["E_Coact"] := "A" - maptbl["E_Coexpr"] := "x" - maptbl["E_Cofail"] := "D" - maptbl["E_Collect"] := "G" - maptbl["E_Comment"] := "#" - maptbl["E_Coret"] := "B" - maptbl["E_Cset"] := "e" - maptbl["E_Ecall"] := "c" - maptbl["E_Efail"] := "f" - maptbl["E_EndCollect"] := "\360" - maptbl["E_Erem"] := "v" - maptbl["E_Eresum"] := "u" - maptbl["E_Eret"] := "r" - maptbl["E_Error"] := "E" - maptbl["E_Esusp"] := "a" - maptbl["E_Exit"] := "X" - maptbl["E_External"] := "j" - maptbl["E_Fcall"] := ":" - maptbl["E_Fconv"] := "J" - maptbl["E_Ffail"] := "M" - maptbl["E_File"] := "g" - maptbl["E_Free"] := "Z" - maptbl["E_Frem"] := "[" - maptbl["E_Fresum"] := "Y" - maptbl["E_Fret"] := "P" - maptbl["E_Fsusp"] := "W" - maptbl["E_Highlight"] := "H" - maptbl["E_Intcall"] := "\351" - maptbl["E_Integer"] := "@" - maptbl["E_Intret"] := "\352" - maptbl["E_Kywdint"] := "^" - maptbl["E_Kywdpos"] := "&" - maptbl["E_Kywdsubj"] := "*" - maptbl["E_Lbang"] := "\301" - maptbl["E_Lcreate"] := "\302" - maptbl["E_Lelem"] := "m" - maptbl["E_List"] := "k" - maptbl["E_Loc"] := "|" - maptbl["E_Lpop"] := "\303" - maptbl["E_Lpull"] := "\304" - maptbl["E_Lpush"] := "\305" - maptbl["E_Lput"] := "\306" - maptbl["E_Lrand"] := "\307" - maptbl["E_Lref"] := "\310" - maptbl["E_Lrgint"] := "L" - maptbl["E_Lsub"] := "\311" - maptbl["E_Lsusp"] := "l" - maptbl["E_MXevent"] := "\370" - maptbl["E_Nconv"] := "N" - maptbl["E_Null"] := "$" - maptbl["E_Ocall"] := "\\" - maptbl["E_Ofail"] := "]" - maptbl["E_Offset"] := "+" - maptbl["E_Opcode"] := "O" - maptbl["E_Orem"] := "\177" - maptbl["E_Oresum"] := "}" - maptbl["E_Oret"] := "`" - maptbl["E_Osusp"] := "{" - maptbl["E_Pause"] := ";" - maptbl["E_Pcall"] := "C" - maptbl["E_Pfail"] := "F" - maptbl["E_Pid"] := "." - maptbl["E_Prem"] := "V" - maptbl["E_Presum"] := "U" - maptbl["E_Pret"] := "R" - maptbl["E_Proc"] := "%" - maptbl["E_Psusp"] := "S" - maptbl["E_Rbang"] := "\312" - maptbl["E_Rcreate"] := "\313" - maptbl["E_Real"] := "d" - maptbl["E_Record"] := "h" - maptbl["E_Refresh"] := "y" - maptbl["E_Region"] := "?" - maptbl["E_Rrand"] := "\314" - maptbl["E_Rref"] := "\315" - maptbl["E_Rsub"] := "\316" - maptbl["E_Ssasgn"] := "\354" - maptbl["E_Sbang"] := "\317" - maptbl["E_Sconv"] := "Q" - maptbl["E_Screate"] := "\320" - maptbl["E_Sdelete"] := "\321" - maptbl["E_Selem"] := "t" - maptbl["E_Set"] := "q" - maptbl["E_Sfail"] := "\341" - maptbl["E_Sinsert"] := "\322" - maptbl["E_Size"] := ">" - maptbl["E_Slots"] := "w" - maptbl["E_Smember"] := "\323" - maptbl["E_Snew"] := "\340" - maptbl["E_Spos"] := "\346" - maptbl["E_Srand"] := "\336" - maptbl["E_Srem"] := "\344" - maptbl["E_Sresum"] := "\343" - maptbl["E_Ssusp"] := "\342" - maptbl["E_Stack"] := "\353" - maptbl["E_StrDeAlc"] := "~" - maptbl["E_String"] := "s" - maptbl["E_Sval"] := "\324" - maptbl["E_Sym"] := "T" - maptbl["E_Table"] := "n" - maptbl["E_Tbang"] := "\325" - maptbl["E_Tconv"] := "K" - maptbl["E_Tcreate"] := "\326" - maptbl["E_Tdelete"] := "\327" - maptbl["E_Telem"] := "o" - maptbl["E_TenureBlock"] := "\362" - maptbl["E_TenureString"] := "\361" - maptbl["E_Tick"] := "." - maptbl["E_Tinsert"] := "\330" - maptbl["E_Tkey"] := "\331" - maptbl["E_Tmember"] := "\332" - maptbl["E_Trand"] := "\337" - maptbl["E_Tref"] := "\333" - maptbl["E_Tsub"] := "\334" - maptbl["E_Tval"] := "\335" - maptbl["E_Tvsubs"] := "i" - maptbl["E_Tvtbl"] := "p" - maptbl["E_Used"] := "=" - maptbl["E_Value"] := "\350" - - maptbl["T_01"] := "A" - maptbl["T_02"] := "B" - maptbl["T_03"] := "C" - maptbl["T_04"] := "D" - maptbl["T_05"] := "E" - maptbl["T_06"] := "F" - maptbl["T_07"] := "G" - maptbl["T_08"] := "H" - maptbl["T_09"] := "I" - maptbl["T_10"] := "J" - maptbl["T_11"] := "K" - maptbl["T_12"] := "L" - maptbl["T_13"] := "M" - maptbl["T_14"] := "N" - -$define T_Mask1 cset("ABCDEFGHIJKLM") - } - - return \maptbl[s] - -end diff --git a/ipl/mprocs/evutils.icn b/ipl/mprocs/evutils.icn deleted file mode 100644 index c1c847e..0000000 --- a/ipl/mprocs/evutils.icn +++ /dev/null @@ -1,94 +0,0 @@ -############################################################################ -# -# File: evutils.icn -# -# Subject: Procedures to support event monitoring -# -# Author: Clinton L. Jeffery -# -# Date: November 23, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This may not be the latest version of this file, despite the date. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ - -# -# location() - encodes a two-dimensional location in an integer -# -procedure location(x, y) - return ishift(x, 16) + y -end - -# -# vertical() - returns the y/line/row component of a location -# -procedure vertical(Loc) - return iand(Loc, 65535) # 16 least-significant bits -end - -# -# horizontal - returns the x/column component of a location -# -procedure horizontal(Loc) - return ishift(Loc, -16) # 16 most-significant bits -end - -# -# prog_len() return the number of lines in TP -# Don't call until EvInit() has been called. -# -procedure prog_len() - local basename, fname, f, count - # - # Extract TP's &file keyword - # - basename := fname := keyword("file", EventSource) - if (not (f := open(fname))) & lpath := getenv("LPATH") || " " then { - # - # Search LPATH for the file if it wasn't in the current directory. - # - lpath ? { - while dir := tab(find(" ")) do { - if fname := dir || "/" || basename & (f := open(fname)) then break - } - if /f then fail - } - } - count := 0 - every !f do count +:= 1 - close(f) - return count -end - -# -# procedure_name() - return the name of a procedure -# -procedure procedure_name(p) - return image(p)[10:0] # strip off "procedure " prefix of image -end - -# -# XHeight(w) - return window height in pixels -# -procedure XHeight(w) - /w := &window - return WAttrib(w, "height") -end - -# -# XWidth(w) - return window width in pixels -# -procedure XWidth(w) - /w := &window - return WAttrib(w, "width") -end diff --git a/ipl/mprocs/hexlib.icn b/ipl/mprocs/hexlib.icn deleted file mode 100644 index 4b7d5b9..0000000 --- a/ipl/mprocs/hexlib.icn +++ /dev/null @@ -1,146 +0,0 @@ -############################################################################ -# -# File: hexlib.icn -# -# Subject: Procedures for hexagons -# -# Author: Clinton Jeffery -# -# Date: August 12, 1994 -# -######################################################################### -# -# This file is in the public domain. -# -############################################################################ -# -# This file is used by algae but is not finished or supported. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ - -global scale,scale2,scale4,scale5,numrows,numcols,drawsegs,drawlefts,drawrights -global drawesegs, q, qq, wHexOutline - -procedure starthex(w) - /scale := 10 - /numrows := 10 - /numcols := 10 - scale2 := 2*scale - scale4 := 4*scale - scale5 := 5*scale - if (numcols % 2) = 0 then numcols +:= 1 - every col := 0 to numcols-1 by 2 do oddcol(w,col*scale4) - every col := 1 to numcols-1 by 2 do evencol(w,col*scale4) -# DrawSegment ! drawsegs -end - -procedure oddcol(w,x) - initial { - i := numrows+1 - i6 := i * 6 - drawlefts := list(i6+1) - drawrights := list(i6+1) - drawsegs := list(i*8+1) - drawlefts[1] := drawrights[1] := drawsegs[1] := w - q := qq := 2 - every i := 0 to numrows do hex(x,i*scale4) - DrawLine ! drawlefts - DrawLine ! drawrights - DrawSegment ! drawsegs - return - } - q := 2 - qq := 2 - every i := 0 to numrows do rehex(x,i*scale4) - DrawLine ! drawlefts - DrawLine ! drawrights - DrawSegment ! drawsegs -end - -procedure evencol(w,x) - initial { - drawesegs := list(numrows*8+1) - drawesegs[1] := w - q := 2 - every i := 0 to numrows-1 do parthex(x,i*scale4+scale2) - DrawSegment ! drawesegs - return - } - q := 2 - every i := 0 to numrows-1 do reparthex(x,i*scale4+scale2) - DrawSegment ! drawesegs -end - -procedure parthex(x,y) - y4 := y + scale4 - drawesegs[q+1] := y4 - drawesegs[q+3] := y4 - drawesegs[q+5] := y - drawesegs[q+7] := y - reparthex(x,y) -end -procedure reparthex(x,y) - x1 := x + scale - x4 := x + scale4 - drawesegs[q ] := x1 - drawesegs[q+2] := x4 - drawesegs[q+4] := x1 - drawesegs[q+6] := x4 - q +:= 8 -end -procedure hex(x,y) - y2 := y + scale2 - y4 := y + scale4 - drawlefts[qq+1] := y - drawlefts[qq+3] := y2 - drawlefts[qq+5] := y4 - drawrights[qq+1] := y - drawrights[qq+3] := y2 - drawrights[qq+5] := y4 - drawsegs[q+1] := y4 - drawsegs[q+3] := y4 - drawsegs[q+5] := y - drawsegs[q+7] := y - rehex(x,y) -end -procedure rehex(x,y) - x1 := x + scale - x4 := x + scale4 - drawlefts[qq] := x1 - drawlefts[qq+2] := x - drawlefts[qq+4] := x1 - drawrights[qq] := x4 - drawrights[qq+2] := x+scale5 - drawrights[qq+4] := x4 - drawsegs[q] := x1 - drawsegs[q+2] := x4 - drawsegs[q+4] := x1 - drawsegs[q+6] := x4 - q +:= 8 - qq +:= 6 -end - -procedure hex_spot(w, row, col) - x := (col-1)*scale4 - y := (row-1)*scale4 - if col % 2 = 0 then y +:= scale2 - x1 := x + scale - x4 := x + scale4 - x5 := x + scale5 - y2 := y + scale2 - y4 := y + scale4 - FillPolygon(w, x1, y, x, y2, x1, y4, x4, y4, x5, y2, x4, y) - DrawLine(wHexOutline, x1, y, x, y2, x1, y4, x4, y4, x5, y2, x4, y, x1, y) -end - -procedure hex_mouse(y,x) - if x % scale4 = 0 then fail - col := x / scale4 + 1 - if col % 2 = 0 then row := (y - scale2) / scale4 + 1 - else row := y / scale4 + 1 - return ishift(col, 16) + row -end diff --git a/ipl/mprocs/loadfile.icn b/ipl/mprocs/loadfile.icn deleted file mode 100644 index 28cd0b2..0000000 --- a/ipl/mprocs/loadfile.icn +++ /dev/null @@ -1,64 +0,0 @@ -############################################################################ -# -# File: loadfile.icn -# -# Subject: Procedure to produce and load program on the fly -# -# Author: Ralph E. Griswold -# -# Date: November 21, 1996 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# loadfile(exp, link, ...) produces and loads a program that generates -# the results of exp. The trailing arguments name link -# files needed for the expression. loadfile() returns a procedure -# that generates the results. -# -############################################################################ -# -# Requires: MT-Icon, system(), pipes, /tmp -# -############################################################################ -# -# Links: io -# -############################################################################ - -link io - -procedure loadfile(exp, links[]) #: produce and load program - local output, prog - static name - - output := tempfile("load", ".icn", "/tmp") - - image(output) ? { - ="file(" - name := tab(find(".icn")) - } - - write(output, "invocable all") - every write(output, "link ", image(!links)) - write(output, "procedure main(args)") - write(output, " suspend ", exp) - write(output, "end") - - close(output) - - if system("mticont -o " || name || " -s " || name || - " >/dev/null 2>/dev/null") ~= 0 then fail - - remove(name || ".icn") # remove source code file - - # Load the program - - prog := load(name) | stop("*** load failure in loadfile") - - return variable("main", prog) - -end diff --git a/ipl/mprocs/opname.icn b/ipl/mprocs/opname.icn deleted file mode 100644 index 9c87667..0000000 --- a/ipl/mprocs/opname.icn +++ /dev/null @@ -1,129 +0,0 @@ -############################################################################ -# -# File: opname.icn -# -# Subject: Procedure to map VM opcodes to their names -# -# Author: Ralph E. Griswold -# -# Date: August 8, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# opnames() maps the virtual-machine instruction numbers to symbolic names. -# -############################################################################ - -procedure opname(i) #: map virtual-machine code to name - static opmap - - initial { - opmap := table("") - - opmap[1] := "Asgn" - opmap[2] := "Bang" - opmap[3] := "Cat" - opmap[4] := "Compl" - opmap[5] := "Diff" - opmap[6] := "Div" - opmap[7] := "Eqv" - opmap[8] := "Inter" - opmap[9] := "Lconcat" - opmap[10] := "Lexeq" - opmap[11] := "Lexge" - opmap[12] := "Lexgt" - opmap[13] := "Lexle" - opmap[14] := "Lexlt" - opmap[15] := "Lexne" - opmap[16] := "Minus" - opmap[17] := "Mod" - opmap[18] := "Mult" - opmap[19] := "Neg" - opmap[20] := "Neqv" - opmap[21] := "Nonnull" - opmap[22] := "Null" - opmap[23] := "Number" - opmap[24] := "Numeq" - opmap[25] := "Numge" - opmap[26] := "Numgt" - opmap[27] := "Numle" - opmap[28] := "Numlt" - opmap[29] := "Numne" - opmap[30] := "Plus" - opmap[31] := "Power" - opmap[32] := "Random" - opmap[33] := "Rasgn" - opmap[34] := "Refresh" - opmap[35] := "Rswap" - opmap[36] := "Sect" - opmap[37] := "Size" - opmap[38] := "Subsc" - opmap[39] := "Swap" - opmap[40] := "Tabmat" - opmap[41] := "Toby" - opmap[42] := "Unions" - opmap[43] := "Value" - opmap[44] := "Bscan" - opmap[45] := "Ccase" - opmap[46] := "Chfail" - opmap[47] := "Coact" - opmap[48] := "Cofail" - opmap[49] := "Coret" - opmap[50] := "Create" - opmap[51] := "Cset" - opmap[52] := "Dup" - opmap[53] := "Efail" - opmap[54] := "Eret" - opmap[55] := "Escan" - opmap[56] := "Esusp" - opmap[57] := "Field" - opmap[58] := "Goto" - opmap[59] := "Init" - opmap[60] := "Int" - opmap[61] := "Invoke" - opmap[62] := "Keywd" - opmap[63] := "Limit" - opmap[64] := "Line" - opmap[65] := "Llist" - opmap[66] := "Lsusp" - opmap[67] := "Mark" - opmap[68] := "Pfail" - opmap[69] := "Pnull" - opmap[70] := "Pop" - opmap[71] := "Pret" - opmap[72] := "Psusp" - opmap[73] := "Push1" - opmap[74] := "Pushn1" - opmap[75] := "Real" - opmap[76] := "Sdup" - opmap[77] := "Str" - opmap[78] := "Unmark" - opmap[80] := "Var" - opmap[81] := "Arg" - opmap[82] := "Static" - opmap[83] := "Local" - opmap[84] := "Global" - opmap[85] := "Mark0" - opmap[86] := "Quit" - opmap[87] := "FQuit" - opmap[88] := "Tally" - opmap[89] := "Apply" - opmap[90] := "Acset" - opmap[91] := "Areal" - opmap[92] := "Astr" - opmap[93] := "Aglobal" - opmap[94] := "Astatic" - opmap[95] := "Agoto" - opmap[96] := "Amark" - opmap[98] := "Noop" - opmap[100] := "SymEvents" - opmap[108] := "Colm" - } - - return opmap[i] - -end diff --git a/ipl/mprocs/typebind.icn b/ipl/mprocs/typebind.icn deleted file mode 100644 index 84bf9ec..0000000 --- a/ipl/mprocs/typebind.icn +++ /dev/null @@ -1,56 +0,0 @@ -############################################################################ -# -# File: typebind.icn -# -# Subject: Procedures to produce table of graphic contexts for type -# -# Author: Ralph E. Griswold and Clinton L. Jeffery -# -# Date: March 4, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# typebind(window, codes, opts) returns a table of graphic contexts bound to -# window with foreground colors keyed by type in the string of event codes. -# -# Codes for which there is no corresponding color are ignored. -# -# Note: Event monitoring global identifiers must be linked by the program -# that uses this procedure. -# -############################################################################ -# -# Links: colormap -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ - -link colormap - -procedure typebind(window, codes, opts) - local code, context - static contexts, color - - initial { - contexts := table() - if /opts then color := colormap("standard") - else color := colormap(opts["p"]) - } - - if /contexts[window] := table() then { - context := contexts[window] - every code := !codes do - context[code] := Clone(window, , "fg=" || \color[code]) - } - contexts[window]["bg"] := Clone(window, "fg=" || WAttrib(window,"bg")) - return contexts[window] - -end - diff --git a/ipl/mprocs/typesyms.icn b/ipl/mprocs/typesyms.icn deleted file mode 100644 index 04dee72..0000000 --- a/ipl/mprocs/typesyms.icn +++ /dev/null @@ -1,71 +0,0 @@ -############################################################################ -# -# File: typesyms.icn -# -# Subject: Procedure to map type codes to event codes -# -# Author: Ralph E. Griswold -# -# Date: June 8, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# typesyms() returns a table that maps type codes to event codes. The -# table can be subscripted either by one-character strings in the style -# of typecode() or by the integer values given by T_type globals. -# -# This procedure is intended for use with event monitors running under -# MT Icon. -# -############################################################################ -# -# See also: typecode.icn -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -procedure typesyms() - static typetable - - initial { - typetable := table() - - typetable["L"] := E_List - typetable["S"] := E_Set - typetable["T"] := E_Table - typetable["R"] := E_Record - typetable["s"] := E_String - typetable["c"] := E_Cset - typetable["i"] := E_Integer - typetable["r"] := E_Real - typetable["f"] := E_File - typetable["n"] := E_Null - typetable["p"] := E_Proc - typetable["C"] := E_Coexpr - - typetable[T_List] := E_List - typetable[T_Set] := E_Set - typetable[T_Table] := E_Table - typetable[T_Record] := E_Record - typetable[T_String] := E_String - typetable[T_Cset] := E_Cset - typetable[T_Integer] := E_Integer - typetable[T_Real] := E_Real - typetable[T_File] := E_File - typetable[T_Null] := E_Null - typetable[T_Proc] := E_Proc - typetable[T_Coexpr] := E_Coexpr - } - - return typetable - -end diff --git a/ipl/mprocs/viewpack.icn b/ipl/mprocs/viewpack.icn deleted file mode 100644 index 1797fd1..0000000 --- a/ipl/mprocs/viewpack.icn +++ /dev/null @@ -1,329 +0,0 @@ -############################################################################ -# -# File: viewpack.icn -# -# Subject: Procedures to visualize color streams -# -# Author: Ralph E. Griswold -# -# Date: May 2, 2001 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# These procedures provide various ways of visualizing a stream of colors. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ - -$define Hold 300 - -# blinking light - -procedure beacon(win, color, value) #: 1C visualization as blinking light - - Fg(win, color) - FillCircle(win, width / 2, height / 2, width / 2) - WDelay(win, Hold) - -end - -# random curves - -procedure curves(win, color, value) #: 1C visualization as random curves - local x0, y0 - - Fg(win, color) - DrawCurve ! [ - win, - x0 := ?width, y0 := ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - .x0, .y0 - ] - - WDelay(win, Hold) - - return - -end - -# "haystack" - -procedure haystack(win, color, value) #: 2CS visualization as "haystack" - static angle, xcenter, ycenter, xorg, yorg, fullcircle - - initial { - fullcircle := 2 * &pi - ycenter := height / 2 - xcenter := width / 2 - } - - Fg(win, color) - angle := ?0 * fullcircle # angle for locating starting point - xorg := xcenter + ?xcenter * cos(angle) - yorg := ycenter + ?ycenter * sin(angle) - angle := ?0 * fullcircle # angle for locating end point - DrawLine(win, xorg, yorg, value * cos(angle) + - xorg, value * sin(angle) + yorg) - - return - -end - -# "nova" - -$define Scale 1.5 -$define Rays 360 - -procedure nova(win, color, value) #: 1C visualization as exploding star - local clear, xorg, yorg, radius, arc, oldlength, length - static fullcircle, radians, advance, erase - - initial { - fullcircle := 2 * &pi - radians := 0 - advance := fullcircle / Rays # amount to advance - erase := list(Rays) - } - - Fg(win, color) - xorg := width / 2 - yorg := height / 2 - radius := ((height < width) | height) / 2.0 - - length := value * Scale - put(erase, length) - oldlength := get(erase) - -# The following are to erase old ray at that angle - -# DrawLine(Background, xorg, yorg, \oldlength * cos(radians) + xorg, -# oldlength * sin(radians) + yorg) - - DrawLine(win, xorg, yorg, length * cos(radians) + - xorg, length * sin(radians) + yorg) - - radians +:= advance - radians %:= fullcircle - - return - -end - -# "pinwheel" - -$define Sectors 240 - -procedure pinwheel(win, color, value) #: 1C visualization as radar sweep - static clear, xorg, yorg, radius, offset - static arc, advance, blank, max, xratio, yratio - static fullcircle, background - - initial { - fullcircle := 2 * &pi - max := real((width < height) | width) - xratio := width / max - yratio := height / max - offset := 0 - advance := fullcircle / Sectors - blank := 2 * advance - xorg := width / 2 - yorg := height / 2 - radius := max / 2 - - # This belongs elsewhere - - background := Clone(win, "bg=" || default_color) - - } - - Fg(win, color) - FillArc(background, 0, 0, width, height, offset + advance, blank) - FillArc(win, 0, 0, width, height, offset, advance) - DrawLine(background, xorg, yorg, xratio * radius * cos(offset) + - xorg, yratio * radius * sin(offset) + yorg) - - offset +:= advance - offset %:= fullcircle - - return - -end - -# random polygons - -procedure polygons(win, color, value) #: 1C visualization as random polygons - local x0, y0 - - Fg(win, color) - FillPolygon ! [ - win, - x0 := ?width, y0 := ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - ?width, ?height, - .x0, .y0 - ] - - WDelay(win, Hold) - - return - -end - -# random dots - -procedure splatter(win, color, value) #: 2CS visualization as random dots - local radius, xplace, yplace - - Fg(win, color) - radius := sqrt(value) - xplace := ?width - 1 - (radius / 2) - yplace := ?height - 1 - (radius / 2) - FillCircle(win, xplace, yplace, radius) - - return - -end - -# scrolling strip - -procedure strip(win, color, value) #: 2CS visualization as scrolling lines - local count - - Fg(win, color) | "black" - if /value | (value = 0) then return - count := log(value, 10) + 1 - every 1 to count do { - CopyArea(win, 1, 0, width - 1, height, 0, 0) - EraseArea(win, width - 1, 0, width - 1, height) - FillRectangle(win, width - 1, 0, 1, height) - } - - return - -end - -procedure symdraw(W, mid, x, y, r) - - FillCircle(W, mid + x, mid + y, r) - FillCircle(W, mid + x, mid - y, r) - FillCircle(W, mid - x, mid + y, r) - FillCircle(W, mid - x, mid - y, r) - - FillCircle(W, mid + y, mid + x, r) - FillCircle(W, mid + y, mid - x, r) - FillCircle(W, mid - y, mid + x, r) - FillCircle(W, mid - y, mid - x, r) - - return - -end - -# symmetric random dots - -procedure symsplat(win, color, value) #: 2CS visualization as symmetric random dots - local radius - static xplace, yplace, oscale - - Fg(win, color) - radius := sqrt(value) - xplace := ?width - 1 - yplace := ?height - 1 - symdraw(win, width / 2, xplace, yplace, radius) - - return - -end - -# evolving vortex - -procedure vortex(win, color, value) #: 1C visualization as an aspirating vortex - local count - static x1, x2, y1, y2 - - initial { - x1 := y1 := 0 - x2 := width - y2 := height - } - - Fg(win, color) - if value = 0 then return - count := log(value, 10) + 1 - every 1 to count do { - if (x2 | y2) < 0 then { - x1 := y1 := 0 - x2 := width - y2 := height - } - DrawRectangle(win, x1, y1, x2 - x1, y2 - y1) - x1 +:= 1 - x2 -:= 1 - y1 +:= 1 - y2 -:= 1 - } - - return - -end - -# random walk -# -# This procedure is suspect -- it seems to wander off the display area. - -$define Delta 30 - -procedure web(win, color, value) #: 2CS visualization as a random walk - static xorg, yorg, x, y, angle, degrees, radians, resid - - initial { - resid := 0 - xorg := ?(width - 1) # starting point - yorg := ?(height - 1) - } - - Fg(win, color) - if resid <= 1 then { - angle := ?0 * 2 * &pi # initial direction for new walk - resid := value - } - - x := xorg + resid * cos(angle) - y := yorg + resid * sin(angle) - - if x > width then { - x := width - } - if y > height then { - y := height - } - if x < 0 then { - x := 0 - } - if y < 0 then { - y := 0 - } - DrawLine(win, xorg, yorg, x, y) - resid -:= sqrt((x - xorg) ^ 2 + (y - yorg) ^ 2) - xorg := x # move to new point - yorg := y - angle := -angle # reflect - - return - -end diff --git a/ipl/mprogs/alcscope.icn b/ipl/mprogs/alcscope.icn deleted file mode 100644 index 2629cf6..0000000 --- a/ipl/mprogs/alcscope.icn +++ /dev/null @@ -1,312 +0,0 @@ -############################################################################ -# -# File: alcscope.icn -# -# Subject: Program to visualize allocation as a kaleidoscopic display -# -# Author: Ralph E. Griswold -# -# Date: July 14, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program displays kaleidoscopic images. The controls on the -# user interface are relatively intuitive -- trying them will give -# a better idea of what's possible than a prose description here. -# -# This program is based on an earlier one by Steve Wampler, which in -# turn was based on a C program by Lorraine Callahan. -# -# This version is adapted to visualize storage management. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: interact, random, vsetup -# -############################################################################ - -link interact -link vsetup -link colormap -link evinit - -# Interface globals - -global vidgets # table of vidgets -global root # the root vidget -global size # size of view area (width & height) -global half # half size of view area -global pane # graphics context for viewing - -# Parameters that can be set from the interface - -global delayval # delay between drawing circles -global density # number of circles in steady state -global draw_proc # drawing procedure -global max_off # maximum offset of circle -global min_off # minimum offset of circle -global scale # scaling factor for sizes -global color # color table - -# State information - -global draw_list # list of pending drawing parameters -global reset # nonnull when view area needs resetting -global state # nonnull when display paused - -$include "evdefs.icn" - -procedure main(args) - - init(args) - - kaleidoscope() - -end - -procedure init(args) - - color := colormap() - - vidgets := ui() - - root := vidgets["root"] - size := vidgets["region"].uw - if vidgets["region"].uh ~= size then stop("*** improper interface layout") - -# Set initial values. - - draw_proc := FillCircle - - state := &null - -# Initialize vidget values. - - density := VGetState(vidgets["density"]) - delayval := VGetState(vidgets["speed"]) - scale := VGetState(vidgets["scale"]) - VSetState(vidgets["shape"], "rings") - -# Get graphics context for drawing. - - half := size / 2 - - pane := Clone("bg=black", "dx=" || (vidgets["region"].ux + half), - "dy=" || (vidgets["region"].uy + half), "drawop=reverse") - Clip(pane, -half, -half, size, size) - - EvInit(args) | ExitNotice("Cannot load SP.") - - every variable("write" | "writes", &eventsource) := -1 - - return - -end - -procedure kaleidoscope() - - # Each time through this loop, the display is cleared and a - # new drawing is started. - - repeat { - - EraseArea(pane, -half, -half, size, size) # clear display - draw_list := [] # new drawing list - reset := &null - - # In this loop a new circle is drawn and an old one erased, once the - # specified density has been reached. This maintains a steady state. - - repeat { - while (*Pending() > 0) | \state do { - ProcessEvent(root, , shortcuts) - if \reset then break break next - } - putcircle() - WDelay(delayval) - - # Don't start clearing circles until the specified density has - # reached. (The drawing list has four elements for each circle.) - - if *draw_list > (4 * density) then clrcircle() - } - } - -end - -procedure putcircle() - local off1, off2, radius, fg - - EvGet(AllocMask) | ExitNotice("SP terminated.") - - fg := color[&eventcode] - radius := sqrt(&eventvalue * scale) - - # get a random center point and radius - - off1 := ?size % half - off2 := ?size % half - - put(draw_list, off1, off2, radius, fg) - - outcircle(off1, off2, radius, fg) - - return - -end - -procedure clrcircle() - - outcircle( - get(draw_list), # off1 - get(draw_list), # off2 - get(draw_list), # radius - get(draw_list) # color - ) - - return - -end - -procedure outcircle(off1, off2, radius, color) - - Fg(pane, color) - - # Draw in symmetric positions. - - draw_proc(pane, off1, off2, radius) - draw_proc(pane, off1, -off2, radius) - draw_proc(pane, -off1, off2, radius) - draw_proc(pane, -off1,-off2, radius) - draw_proc(pane, off2, off1, radius) - draw_proc(pane, off2, -off1, radius) - draw_proc(pane, -off2, off1, radius) - draw_proc(pane, -off2,-off1, radius) - - return - -end - -procedure density_cb(vidget, value) - - density := value - - reset := 1 - -end - -procedure speed_cb(vidget, value) - - delayval := value - - return - -end - -procedure file_cb(vidget, value) - - case value[1] of { - "snapshot @S": snapshot(pane, -half, -half, size, size) - "quit @Q": exit() - } - - return - -end - -procedure scale_cb(vidget, value) - - scale := value - - return - -end - -procedure pause_cb(vidget, value) - - state := value - - return - -end - -procedure reset_cb(vidget, value) - - reset := 1 - - return - -end - -procedure shape_cb(vidget, value) - - draw_proc := case value of { - "discs": FillCircle - "rings": DrawCircle - } - - reset := 1 - - return - -end - -procedure shortcuts(e) - - if &meta then - case map(e) of { # fold case - "q": exit() - "s": snapshot(pane, -half, -half, size, size) - } - - return - -end - -#===<<vib:begin>>=== modify using vib; do not remove this marker line -procedure ui_atts() - return ["size=600,455", "bg=gray-white", "label=kaleido"] -end - -procedure ui(win, cbk) -return vsetup(win, cbk, - [":Sizer:::0,0,600,455:kaleido",], - ["density:Slider:h:1:41,171,100,15:10,100,50",density_cb], - ["file:Menu:pull::12,3,36,21:File",file_cb, - ["snapshot @S","quit @Q"]], - ["label07:Label:::7,120,28,13:slow",], - ["label08:Label:::151,120,28,13:fast",], - ["label10:Label:::64,270,7,13:1",], - ["label11:Label:::124,270,7,13:5",], - ["label12:Label:::47,200,14,13:10",], - ["label13:Label:::116,200,21,13:100",], - ["label14:Label:::78,200,14,13:50",], - ["label9:Label:::43,270,14,13:.2",], - ["lbl_density:Label:::67,151,49,13:density",], - ["lbl_scale:Label:::74,220,35,13:scale",], - ["lbl_speed:Label:::74,100,35,13:speed",], - ["line:Line:::0,30,600,30:",], - ["line1:Line:::68,256,68,266:",], - ["line2:Line:::128,256,128,266:",], - ["line3:Line:::54,256,54,266:",], - ["line4:Line:::128,186,128,196:",], - ["line5:Line:::55,186,55,196:",], - ["line6:Line:::86,186,86,196:",], - ["pause:Button:regular:1:33,55,45,20:pause",pause_cb], - ["reset:Button:regular::111,55,45,20:reset",reset_cb], - ["scale:Slider:h:1:42,240,100,15:0.1,5,1",scale_cb], - ["shape:Choice::2:64,330,64,42:",shape_cb, - ["discs","rings"]], - ["speed:Slider:h:1:41,121,100,15:100,0,0",speed_cb], - ["region:Rect:raised::187,42,400,400:",], - ) -end -#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/mprogs/alcview.icn b/ipl/mprogs/alcview.icn deleted file mode 100644 index 85a007a..0000000 --- a/ipl/mprogs/alcview.icn +++ /dev/null @@ -1,258 +0,0 @@ -########################################################################### -# -# File: alcview.icn -# -# Subject: Program to display allocation events in various ways -# -# Author: Ralph E. Griswold -# -# Date: February 16, 1998 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program maps allocation events into colors and provides various -# abstract visualizations of them. -# -# Several visualizations are available: -# -# beacon blinking light -# curves random closed curves -# haystack* randomly oriented lines -# nova* radiating lines -# pinwheel revolving sequence of sectors in a circle -# polygons random polygons -# splatter* randomly placed dots -# strip scrolling strip of vertical lines -# symplat as splatter, but in symmetric pattern -# vortex* expanding/contracting square vortex -# web* random walk -# -# The visualizations marked with asterisks use the size information. The -# others do not. -# -# In terms of the monitoring framework terminology, this program -# provides abstract visualizations for in an event space consisting -# of category/size pairs -- 2CS -- in which the categories are colors. -# -# The interface controls provide for: -# -# control of the display speed -# pausing the display -# resetting the display -# setting the period between automatic resetting -# changing the view -# -############################################################################ -# -# Requires: MT Icon, event monitoring, Version 9 graphics -# -############################################################################ -# -# Links: colormap, evinit, interact, viewpack, vsetup -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link colormap -link evinit -link interact -link viewpack -link vsetup - -$include "evdefs.icn" - -global color -global vidgets -global viewer -global root -global pane -global state -global reset # vidget for resetting callback -global snap -global name -global point -global count # drawing count -global done -global default_color # default in case of bad color specification -global draw # drawing procedure for visualization -global width -global height -global period # automatic resetting count -global refresh # resetting switch - -# Prevent linker from deleting procedures that are not explicitly referenced. -invocable "beacon" -invocable "curves" -invocable "haystack" -invocable "nova" -invocable "pinwheel" -invocable "polygons" -invocable "splatter" -invocable "strip" -invocable "symsplat" -invocable "vortex" -invocable "web" - -# Main procedure - -procedure main(args) - - init(args) - - display() - -end - -# Initialization - -procedure init(args) - - EvInit(args) | stop("*** cannot load SP.") - - vidgets := ui() - - root := vidgets["root"] - reset := vidgets["reset"] - - state := &null - - width := vidgets["pane"].uw - height := vidgets["pane"].uh - - default_color := "black" - - refresh := period := -1 - count := 0 - done := &null - - viewer := "symsplat" - - color := colormap() - - draw := proc(viewer) | stop("*** internal inconsistency") - - pane := Clone("dx=" || vidgets["pane"].ux, "dy=" || vidgets["pane"].uy, - "bg=" || default_color) - Clip(pane, 0, 0, width, height) - - reset_cb() - -end - -# Display driver - -procedure display() - - repeat { - if period = 0 then reset_cb() - while (*Pending() > 0) | \state do - ProcessEvent(root, , shortcuts) - EvGet(AllocMask) | exit() - draw(pane, color[&eventcode], &eventvalue) - period -:= 1 - } - -end - -# Callbacks - -procedure quit_cb() - - exit() - -end - -procedure snapshot_cb() - - snapshot(pane, 0, 0, width, height) - - return - -end - -procedure period_cb() - - repeat { - if TextDialog("Reset period (negative value disables _ - automatic resetting:", , refresh, 6) == "Cancel" then fail - if refresh := period := integer(dialog_value[1]) then return - else { - Notice("Invalid period specification.") - next - } - } - -end - -procedure reset_cb() - - EraseArea(pane, 0, 0, width, height) - - period := refresh - - return - -end - -procedure view_cb() - static views - - initial { - views := [ - "beacon", - "curves", - "haystack", - "nova", - "pinwheel", - "polygons", - "splatter", - "strip", - "symsplat", - "vortex", - "web" - ] - } - - if SelectDialog("Select viewer:", views, viewer) == "Cancel" then fail - viewer := dialog_value - draw := proc(viewer) | - return FailNotice("Internal inconsistency; viewer not found.") - reset_cb() - - return - -end - -procedure shortcuts(e) - - if &meta then - case map(e) of { - "q": exit() - "r": reset_cb() - } - -end - -#===<<vib:begin>>=== modify using vib; do not remove this marker line -procedure ui_atts() - return ["size=311,210", "bg=pale gray"] -end - -procedure ui(win, cbk) -return vsetup(win, cbk, - [":Sizer:::0,0,311,210:",], - ["period:Button:regular::11,96,91,20:reset period",period_cb], - ["quit:Button:regular::34,19,42,20:quit",quit_cb], - ["reset:Button:regular::34,55,42,20:reset",reset_cb], - ["view:Button:regular::15,133,84,20:select view",view_cb], - ["pane:Rect:grooved::113,9,190,190:",], - ) -end -#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/mprogs/algae.icn b/ipl/mprogs/algae.icn deleted file mode 100644 index 1a92952..0000000 --- a/ipl/mprogs/algae.icn +++ /dev/null @@ -1,356 +0,0 @@ -######################################################################### -# -# File: algae.icn -# -# Subject: Program to show expression evaluation as ``algae'' -# -# Author: Clinton Jeffery -# -# Date: November 22, 1997 -# -######################################################################### -# -# This file is in the public domain. -# -############################################################################ -# -# Press ESC or q to quit -# Left mouse assigns specific (row,column) break "points" -# Middle mouse assigns absolute depth and width break lines -# Right button erases assigned break "points" -# -# When paused due to a break, you can: -# -# c to continue -# s to single step -# C to clear one point and continue -# " " to clear everything and continue -# -######################################################################### -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link evinit -link evutils -link options -link optwindw -link hexlib -link evaltree - -global scale, # cell (hexagon or square) size - step, # single step mode - numrows, # number of cell rows - numcols, # number of cell columns - spot, # cell-fill procedure (hex or square) - mouse, # cell-mouse-locator procedure - Visualization, # the window - wHexOutline, # binding for drawing cell outlines - depthbound, # call-depth on which to break - breadthbound, # suspension-width on which to break - hotspots # table of individual cells on which to break - -record algae_activation(node, row, column, parent, children, color) - - -# -# main() - program entry point. The main loop is in evaltree(). -# -procedure main(av) - local codes, algaeoptions - # - # pull off algae options (don't consume child's options in this call - # to options()). - # - algaeoptions := [] - while av[1][1] == "-" do { - put(algaeoptions, pop(av)) - if algaeoptions[-1] == "-f" then put(algaeoptions, pop(av)) - } - EvInit(av) | stop("Can't EvInit ",av[1]) - codes := algae_init(algaeoptions) - evaltree(codes, algae_callback, algae_activation) - WAttrib("windowlabel=Algae: finished") - EvTerm(&window) -end - -# -# algae_init() - initialization and command-line processing. -# This procedure supplies default behavior and handles options. -# -procedure algae_init(algaeoptions) - local t, position, geo, codes, i, cb, coord, e, s, x, y, m, row, column - t := options(algaeoptions, - winoptions() || "P:S:-geo:-square!-func!-scan!-op!-noproc!") - /t["L"] := "Algae" - /t["B"] := "cyan" - scale := \t["S"] | 12 - if \t["square"] then { - spot := square_spot - mouse := square_mouse - } - else { - scale /:= 4 - spot := hex_spot - mouse := hex_mouse - } - codes := cset(E_MXevent) - if /t["noproc"] then codes ++:= ProcMask - if \t["scan"] then codes ++:= ScanMask - if \t["func"] then codes ++:= FncMask - if \t["op"] then codes ++:= OperMask - hotspots := table() - &window := Visualization := optwindow(t) | stop("no window") - numrows := (XHeight() / (scale * 4)) - numcols := (XWidth() / (scale * 4)) - wHexOutline := Color("white") # used by the hexagon library - if /t["square"] then starthex(Color("black")) - return codes -end - -# -# algae_callback() - evaltree callback procedure for algae. -# Called for each event, it updates the screen to correspond -# to the change in the activation tree. -# -procedure algae_callback(new, old) - local coord, e - initial { - old.row := old.parent.row := 0; old.column := old.parent.column := 1 - } - case &eventcode of { - !CallCodes: { - new.column := (old.children[-2].column + 1 | computeCol(old)) | stop("eh?") - new.row := old.row + 1 - new.color := Color(&eventcode) - spot(\old.color, old.row, old.column) - } - !ReturnCodes | - !FailCodes: spot(Color("light blue"), old.row, old.column) - !SuspendCodes | - !ResumeCodes: spot(old.color, old.row, old.column) - !RemoveCodes: { - spot(Color("black"), old.row, old.column) - WFlush(Color("black")) - delay(100) - spot(Color("light blue"), old.row, old.column) - } - E_MXevent: do1event(&eventvalue, new) - } - spot(Color("yellow"), new.row, new.column) - coord := location(new.column, new.row) - if \step | (\breadthbound <= new.column) | (\depthbound <= new.row) | - \ hotspots[coord] then { - step := &null - WAttrib("windowlabel=Algae stopped: (s)tep (c)ont ( )clear ") - while e := Event() do - if do1event(e, new) then break - WAttrib("windowlabel=Algae") - if \ hotspots[coord] then spot(Color("light blue"), new.row, new.column) - } -end - - -# -# procedures for the "-square" option, display Algae using squares -# instead of hexagons. -# - -# Draw a square at (row, column) -procedure square_spot(w, row, column) - FillRectangle(w, (column - 1) * scale, (row - 1) * scale, scale, scale) -end - - -# encode a location value (base 1) for a given x and y pixel -procedure square_mouse(y, x) - return location(x / scale + 1, y / scale + 1) -end - -# -# clearspot() removes a "breakpoint" at (x,y) -# -procedure clearspot(spot) - local x, y, s2, x2, y2 - - hotspots[spot] := &null - y := vertical(spot) - x := horizontal(spot) - every s2 := \!hotspots do { - x2 := horizontal(s2) - y2 := vertical(s2) - } - spot(Visualization, y, x) -end - -# -# setspot() sets a breakpoint at (x,y) and marks it orange -# -procedure setspot(loc) - local x, y - - hotspots[loc] := loc - y := vertical(loc) - x := horizontal(loc) - spot(Color("orange"), y, x) -end - -# -# do1event() processes a single user input event. -# -procedure do1event(e, new) - local m, xbound, ybound, row, column, x, y, s, p - - case e of { - "q" | - "\e": exit() - "s": { # execute a single step - step := 1 - return - } - "C": { # clear a single break point - clearspot(location(new.column, new.row)) - return - } - " ": { # space character: clear all break points - if \depthbound then { - every y := 1 to numcols do { - if not who_is_at(depthbound, y, new) then - spot(Visualization, depthbound, y) - } - } - if \breadthbound then { - every x := 1 to numrows do { - if not who_is_at(x, breadthbound, new) then - spot(Visualization, x, breadthbound) - } - } - every s := \!hotspots do { - x := horizontal(s) - y := vertical(s) - spot(Visualization, y, x) - } - hotspots := table() - depthbound := breadthbound := &null - return - } - &mpress | &mdrag: { # middle button: set bound box break lines - if m := mouse(&y, &x) then { - row := vertical(m) - column := horizontal(m) - if \depthbound then { # erase previous bounding box, if any - every spot(Visualization, depthbound, 1 to breadthbound) - every spot(Visualization, 1 to depthbound, breadthbound) - } - depthbound := row - breadthbound := column - # - # draw new bounding box - # - every x := 1 to breadthbound do { - if not who_is_at(depthbound, x, new) then - spot(Color("orange"), depthbound, x) - } - every y := 1 to depthbound - 1 do { - if not who_is_at(y, breadthbound, new) then - spot(Color("orange"), y, breadthbound) - } - } - } - &lpress | &ldrag: { # left button: toggle single cell breakpoint - if m := mouse(&y, &x) then { - xbound := horizontal(m) - ybound := vertical(m) - if hotspots[m] === m then - clearspot(m) - else - setspot(m) - } - } - &rpress | &rdrag: { # right button: report node at mouse location - if m := mouse(&y, &x) then { - column := horizontal(m) - row := vertical(m) - if p := who_is_at(row, column, new) then - WAttrib("windowlabel=Algae " || image(p.node)) - } - } - } -end - -# -# who_is_at() - find the activation tree node at a given (row, column) location -# -procedure who_is_at(row, col, node) - while node.row > 1 & \node.parent do - node := node.parent - return sub_who(row, col, node) # search children -end - -# -# sub_who() - recursive search for the tree node at (row, column) -# -procedure sub_who(row, column, p) - local k - if p.column === column & p.row === row then return p - else { - every k := !p.children do - if q := sub_who(row, column, k) then return q - } -end - -# -# computeCol() - determine the correct column for a new child of a node. -# -procedure computeCol(parent) - local col, x, node - node := parent - while \node.row > 1 do # find root - node := \node.parent - if node === parent then return parent.column - if col := subcompute(node, parent.row + 1) then { - return max(col, parent.column) - } - else return parent.column -end - -# -# subcompute() - recursive search for the leftmost tree node at depth row -# -procedure subcompute(node, row) - # check this level for correct depth - if \node.row = row then return node.column + 1 - # search children from right to left - return subcompute(node.children[*node.children to 1 by -1], row) -end - -# -# Color(s) - return a binding of &window with foreground color s; -# allocate at most one binding per color. -# -procedure Color(s) - static t, magenta - initial { - magenta := Clone(&window, "fg=magenta") | stop("no magenta") - t := table() - /t[E_Fcall] := Clone(&window, "fg=red") | stop("no red") - /t[E_Ocall] := Clone(&window, "fg=chocolate") | stop("no chocolate") - /t[E_Snew] := Clone(&window, "fg=purple") | stop("no purple") - } - if *s > 1 then - / t[s] := Clone(&window, "fg=" || s) | stop("no ",image(s)) - else - / t[s] := magenta - return t[s] -end - -procedure max(x,y) - if x < y then return y else return x -end diff --git a/ipl/mprogs/allocwrl.icn b/ipl/mprogs/allocwrl.icn deleted file mode 100644 index 8521a8f..0000000 --- a/ipl/mprogs/allocwrl.icn +++ /dev/null @@ -1,167 +0,0 @@ -############################################################################ -# -# File: allocwrl.icn -# -# Subject: Program to display storage allocation in VRML -# -# Author: Ralph E. Griswold -# -# Date: March 26, 2002 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program produces VRML 1.0 worlds with shapes representing storage -# allocation in the program it monitors. -# -# The structures normally are laid out in the x-z plane along a path with -# the shapes rising in the y direction. The size of the allocation -# determines the size of the shapes. The same shape is used for all -# allocations, but the color indicates the type of allocation. -# -# The kinds of allocation modeled are given by masks: -# -# structs only allocation related to Icon's structure types -# blocks all allocations in the block region -# non-structs all allocations except for structures -# -# The supported shapes are: -# -# cylinder -# cuboid -# cone -# -# In this version, if the path file is exhausted before the SP terminates, -# the path file is closed and reopened. -# -############################################################################ -# -# Requires: MT Icon -# -############################################################################ -# -# Links: colormap, dialog, emutils, evinit, interact, options, vrml, -# vrml1lib -# -############################################################################ - -link colormap -link dialog -link emutils -link evinit -link interact -link vrml -link vrml1lib - -$include "evdefs.icn" - -procedure main(args) - local model, color_table, code, object_list, trans, mask, object - local path, input, scale, steps, symbol, hfactor, color, shape - local ashape, output - - if TextDialog("Configuration:", - ["SP", "path file", "coordinate scale", "shape scale", - "number of events", "mask", "shape", "world file"], - ["structalc", "line.path", 10.0, 0.2, - 200, "structs", "cylinder", "alloc.wrl"], - [15, 30, 5, 5, 5, 10, 10, 20] - ) == "Cancel" then exit() - - args := [dialog_value[1]] - path := dialog_value[2] - scale := dialog_value[3] - hfactor := dialog_value[4] - steps := dialog_value[5] - mask := case dialog_value[6] of { - "structs" | &null: cset(E_List || E_Lelem || E_Record || E_Selem || - E_Set || E_Slots || E_Table || E_Telem || E_Tvtbl) - "blocks": AllocMask -- (E_String || E_Coexpr) - "strings": cset(E_String) - default: ExitNotice("Invalid mask.") - } - ashape := case dialog_value[7] of { - "cylinder" | &null: Cylinder(2, 2) - "cuboid": Cube(4, 2, 4) - "cone": Cone(2, 2) - default: ExitNotice("Invalid shape.") - } - output := open(dialog_value[8], "w") | - ExitNotice("Cannot open " || dialog_value[8]) - - EvInit(args) | ExitNotice("Cannot load SP.") - - variable("write", &eventsource) := -1 # turn off output in SP - variable("writes", &eventsource) := -1 - - model := [] # list of children - - color_table := colormap() # standard colors - - every code := key(color_table) do { # convert colors to shapes - color := vrml_color(color_table[code]) # standard color - symbol := evsym(code) # use event code name - shape := Separator([ - Material(color), # diffuse color only - Translation("0 1 0"), - ashape, - Translation("0 -1 0") - ]) - - color_table[code] := USE(symbol) # put USE node in table - put(model, DEF(symbol, shape)) # create DEF node - } - - model := [Switch(-1, model)] - - input := open(path) | ExitNotice("Cannot open path file.") - - trans := "0 0 0" # initial "translation" - - every 1 to steps do { - EvGet(mask) | { # get allocation event - write(&errout, "*** event stream terminated") - break - } - object := \color_table[&eventcode] | { # get shape - write(&errout, "*** no entry for ", evsym(&eventcode)) - next - } - trans := Translation(scale_translate(read(input), scale)) | { - Notice("Path ended.") - break - } - put( - model, - Separator([ - trans, - Transform(, , "1.0 " || (&eventvalue * hfactor) || " 1.0"), - object - ]) - ) - } - - vrml1(Group(model), output) # generate world - -end - -procedure scale_translate(s, n) - local x, y, z - - s ? { - x := tab(find(" ")) - move(1) - y := tab(find(" ")) - move(1) - z := tab(0) - } - - return (x * n) || " " || (y * n) || " " || (z * n) - -end - - - diff --git a/ipl/mprogs/anim.icn b/ipl/mprogs/anim.icn deleted file mode 100644 index 604acca..0000000 --- a/ipl/mprogs/anim.icn +++ /dev/null @@ -1,254 +0,0 @@ -############################################################################ -# -# File: anim.icn -# -# Subject: Program to show animated display of Icon source code -# -# Author: Gregg M. Townsend, modified by Ralph E. Griswold -# -# Date: February 28, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# anim displays a miniaturized program listing, highlighting each -# line as it is executed. -# -# Two accompanying barcharts display execution profiles. The one on -# the extreme left shows the number of clock ticks attributable to each -# source line. The second chart shows the number of times each line was -# executed. -# -# A chart to the right of the listing displays a time-based history -# similar to that of the "roll" program (q.v.). -# -# usage: anim [options] [arg...] -# -# -d n decay after n new line events -# -b n length of barcharts (0 to disable) -# -z n length of history (0 to disable) -# -t n ticks per history pixel -# -# -s n vertical line spacing, in pixels -# -w n width of one character, in pixels -# -h n height of one character, in pixels -# -p n set in pointsize n (OpenWindows only; overrides -w and -h) -# -# -P x program text color -# -C x comment color -# -A x active text color -# -O x old-text color (after fading) -# -R x background color for barcharts and history -# -S n spacing between sections of the display -# -# plus standard options from optwindow.icn -# (-F sets the color used for the barcharts and history) -# -# Setting -s or -p establishes good defaults for the other sizes. -# -# It is assumed that the program source file can be found by appending -# ".icn" to the icode file name. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: em_setup, evinit, evmux, barchart, decay, options, optwindw, -# strpchrt -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link em_setup -link evinit -link evmux -link barchart -link decay -link options -link optwindw -link strpchrt - -global progname, opttab, ifile, font -global gcP, gcC, gcA, gcO, gcR -global margin, gutter, textx -global code, pos1, pos2 -global xsiz, ysiz, spacing, dp - -procedure main(args) - local win, len, lno, cs, i, maxlines, lifetime - local hchart, hlength, hscale - local barlength, barwidth, linescale, linecount, linebars - local nticks, tickscale, tickcount, tickbars - local src, linemask - - linemask := 2 ^ 16 -1 - progname := "anim" - maxlines := 1000 - opttab := options (args, winoptions() || "d+b+z+t+s+w+h+p+P:C:A:O:R:S:") - lifetime := \opttab["d"] | 3 - barlength := \opttab["b"] | 40 - hlength := \opttab["z"] | 90 - tickscale := 1.00 - linescale := 0.25 - hscale := \opttab["t"] | 10 - gutter := \opttab["S"] | 10 - - # default to tiny-text mode under OpenWindows - if (not \opttab[!"swhp"]) & getenv ("NEWSSERVER") then - opttab["p"] := 6 - - if i := \opttab["p"] then { - i >:= 13 # maximum size - font := "lucidasanstypewriter-" || i - # -p 1 2 3 4 5 6 7 8 9 10 11 12 13 - xsiz := [1,1,2,2,3,4,4, 5, 5 ,6, 7, 7, 8] [i] - ysiz := [2,3,4,5,7,8,9,10,11,11,12,13,14] [i] - spacing := \opttab["s"] | i - } - else { - spacing := \opttab["s"] | \opttab["h"] + 1 | 4 - xsiz := \opttab["w"] | 0 < integer (0.6 * spacing + 0.5) | 1 - ysiz := \opttab["h"] | 0 < spacing - 1 | 1 - } - - EvInit (args) | stop ("can't load icode file") - - # read source file into memory - - src := prog_name() - ifile := open(src) | stop (progname, ": can't open ", src) - every put(code := [], detab(trim(!ifile \ maxlines))) - - pos1 := list(*code) - pos2 := list(*code) - every i := 1 to *code do - code[i] ? { - tab(many(' ')) - if pos(0) | ="#" then next - pos1[i] := &pos - pos2[i] := pos1[i] + *trim(tab(upto('#')|0)) - } - - if /opttab["W"] then { # calculate window width if not specified - len := 0 - every len <:= *!code - len *:= xsiz - if barlength > 0 then - len +:= 2 * barlength + 2 * gutter - if hlength > 0 then - len +:= gutter + hlength - opttab["W"] := len - } - - /opttab["H"] := spacing * *code - /opttab["L"] := "Anim" - /opttab["F"] := "goldenrod" - /opttab["R"] := "floralwhite" - /opttab["M"] := -1 - win := optwindow (opttab, "cursor=off", "echo=off") - if \font then - Font (win, font) | stop ("can't set font ", font) - margin := opttab["M"] - - Bg (gcR := Clone(win), opttab["R"]) - - if barlength = 0 then - textx := margin - else { - barwidth := spacing - 1 - if barwidth = 0 then - barwidth := 1 - tickcount := list (*code, 0) - tickbars := barchart (gcR, margin+barlength-1, margin, - 0, spacing, -tickscale, *code, barlength, barwidth) - linecount := list (*code, 0) - linebars := barchart (gcR, margin+barlength+gutter+barlength-1, margin, - 0, spacing, -linescale, *code, barlength, barwidth) - textx := margin + 2 * gutter + 2 * barlength - } - - if hlength > 0 then { - hchart := stripchart (gcR, margin + opttab["W"] - hlength, margin, - hlength, spacing * *code) - } - - if \font then { - Fg (gcP := Clone(win), \opttab["P"] | "gray70") - Fg (gcC := Clone(win), \opttab["C"] | "gray90") - Fg (gcO := Clone(win), \opttab["O"] | "black") - Bg (gcA := Clone(gcO), \opttab["A"] | "red") - } - else { - Fg (gcP := Clone(win), \opttab["P"] | "gray70") - Fg (gcC := Clone(win), \opttab["C"] | "gray90") - Fg (gcA := Clone(win), \opttab["P"] | "indianred") - Fg (gcO := Clone(win), \opttab["O"] | "peachpuff") - } - - every i := 1 to *code do { - docmt (gcC, i) # show comments - docode (gcP, i) # show initial code listing - } - - dp := dpipe (docode, lifetime, gcA, gcO) # initialize decay pipe - cs := E_Loc ++ E_Tick - nticks := 0 - - while EvGet (cs) do # for each line event - if &eventcode === E_Loc then { - decay (dp, lno := iand(&eventvalue, linemask)) # mark line - setbar (\linebars, lno, linecount[lno] +:= 1) - smark (\hchart, margin + spacing * (lno-1), margin + spacing * lno - 1) - } - else if &eventcode === E_Tick then { - setbar (\tickbars, \lno, tickcount[\lno] +:= 1) - if (nticks +:= 1) % hscale = 0 then - sadvance (\hchart) - } - - every 1 to lifetime do - decay (dp) # flush decay pipe - quitsensor (win, 1) # wait for quit signal - end - -procedure docode (gc, lno) - doblock (gc, lno, \pos1[lno], pos2[lno]); - return - end - -procedure docmt (gc, lno) - local p - code[lno] ? { - tab(upto('#')) | return - while not pos(0) do { - p := &pos - doblock (gc, lno, p, tab(upto(' ')|0) & &pos) - tab(many(' ')) - } - } - return - end - -procedure doblock (gc, lno, pos1, pos2) - local x - - x := textx + xsiz * (pos1 - 1) - if \font then { - GotoXY(gc, x, margin + spacing * lno - 1) - writes(gc, code[lno][pos1:pos2]) - } - else { - FillRectangle(gc, x, margin + spacing*(lno-1), xsiz*(pos2-pos1), ysiz) - } - return - end diff --git a/ipl/mprogs/callcnt.icn b/ipl/mprogs/callcnt.icn deleted file mode 100644 index c4063cf..0000000 --- a/ipl/mprogs/callcnt.icn +++ /dev/null @@ -1,122 +0,0 @@ -############################################################################ -# -# File: callcnt.icn -# -# Subject: Program to count calls -# -# Author: Ralph E. Griswold -# -# Date: June 8, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program tabulates calls in a monitored program. -# -############################################################################ -# -# Links: evinit, opsyms -# -############################################################################ -# -# Requires: MT Icon and event monitoring -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link opsyms - -$include "evdefs.icn" - -procedure main(args) - local opertable, fnctable, rectable, proctable, opmap, output, mask, oper - local count, fnc - - EvInit(args) - - opertable := table(0) - fnctable := table(0) - proctable := table(0) - - opmap := opsyms() - - output := open("callcnt", "x", "height=800", # If this fails, output goes to - "width=200") # standard output - - write(output, " Tabulating calls for ", args[1]) - - mask := E_Ocall ++ E_Fcall ++ E_Pcall - - while EvGet(mask) do - case &eventcode of { - E_Ocall: opertable[&eventvalue] +:= 1 - E_Fcall: fnctable[&eventvalue] +:= 1 - E_Pcall: proctable[&eventvalue] +:= 1 - } - - opertable := sort(opertable,3) - fnctable := sort(fnctable,3) - rectable :=copy(fnctable) - proctable := sort(proctable,3) - - write(output, "\n operation calls\n") - while oper := get(opertable) do { - count := get(opertable) - write(output, " ", left(\opmap[oper], 20), right(count, 7)) - } - - write(output, "\n function calls\n") - while fnc := get(fnctable) do { - count := get(fnctable) - write(output, " ", left(fname(fnc), 20), right(count, 7)) - } - - write(output, "\n record constructor calls\n") - while fnc := get(rectable) do { - count := get(rectable) - write(output, " ", left(cname(fnc), 20), right(count, 7)) - } - - write(output, "\n procedure calls\n") - while write(output, " ", left(pname(get(proctable)), 20), - right(get(proctable), 7)) - - Event(\output) # wait for event if window - -end - -procedure cname(f) - - return image(f) ? { - ="function " - if ="record constructor " then return tab(0) - else fail - } - -end - -procedure fname(f) - - return image(f) ? { - ="function " - if ="record constructor " then fail - else tab(0) - } - -end - -procedure pname(p) - - return image(p) ? { - ="procedure " - tab(0) - } - -end diff --git a/ipl/mprogs/cmpsum.icn b/ipl/mprogs/cmpsum.icn deleted file mode 100644 index 79fdf8f..0000000 --- a/ipl/mprogs/cmpsum.icn +++ /dev/null @@ -1,106 +0,0 @@ -############################################################################ -# -# File: cmpsum.icn -# -# Subject: Program to tabulate comparisons -# -# Author: Ralph E. Griswold -# -# Date: September 27, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates comparisons. It is called as -# -# cmpsum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, options, procname -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link options -link procname - -$include "evdefs.icn" - -procedure main(args) - local opts, itime, output, succtbl, failtbl, cmask, rmask, cmplist, op - local greater, greatereq, noteql, eql, less, lesseq, valeql, valnoteql - local strgreater, strgreatereq, strnoteql, streql, strless, strlesseq - - opts := options(args, "o:t") - - output := open(\opts["o"], "w") | &output - - if \opts["t"] then itime := &time - - EvInit(args) | stop("*** cannot load program") # initialize interface - - succtbl := table(0) - failtbl := table(0) - - cmask := E_Ocall - rmask := E_Oret ++ E_Ofail - - eql := proc("=", 2) - less := proc("<", 2) - lesseq := proc("<=", 2) - greater := proc(">", 2) - greatereq := proc(">=", 2) - noteql := proc("~=", 2) - streql := proc("==", 2) - strless := proc("<<", 2) - strlesseq := proc("<<=", 2) - strgreater := proc(">>", 2) - strgreatereq := proc(">>=", 2) - strnoteql := proc("~==", 2) - valeql := proc("===", 2) - valnoteql := proc("~===", 2) - - while EvGet(cmask) do { - if (op := &eventvalue) === ( - eql | less | lesseq | greater | greatereq | noteql | - streql | strless | strlesseq | strgreater | strgreatereq | strnoteql | - valeql | valnoteql - ) then { - EvGet(rmask) - if &eventcode === E_Oret then succtbl[op] +:= 1 - else failtbl[op] +:= 1 - } - } - - write(output, "\nSuccessful comparisons:\n") - cmplist := sort(succtbl, 3) - while write(output, left(procname(get(cmplist)), 6), right(get(cmplist), 7)) - - write(output, "\nFailed comparisons:\n") - cmplist := sort(failtbl, 3) - while write(output, left(procname(get(cmplist)), 6), right(get(cmplist), 7)) - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end diff --git a/ipl/mprogs/cnvsum.icn b/ipl/mprogs/cnvsum.icn deleted file mode 100644 index b5e446a..0000000 --- a/ipl/mprogs/cnvsum.icn +++ /dev/null @@ -1,117 +0,0 @@ -############################################################################ -# -# File: cnvsum.icn -# -# Subject: Program to tabulate type-conversion activity -# -# Author: Ralph E. Griswold -# -# Date: August 13, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates type-conversion activity. It is called as -# -# cnvsum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, options, procname, typecode -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link options -link procname -link typecode - -$include "evdefs.icn" - -procedure main(args) - local opts, itime, cnvlist, esucctbl, efailtbl, isucctbl, ifailtbl, output - local mmask, cmask, in, pair, name - - opts := options(args, "o:t") - - output := open(\opts["o"], "w") | &output - - if \opts["t"] then itime := &time - - EvInit(args) | stop("*** cannot load program") # initialize interface - - esucctbl := table(0) - efailtbl := table(0) - isucctbl := table(0) - ifailtbl := table(0) - - mmask := E_Fcall ++ E_Aconv - cmask := E_Fconv ++ E_Sconv ++ E_Nconv - - while EvGet(mmask) do { - case &eventcode of { - E_Fcall: { - if (name := procname(&eventvalue)) == - ("integer" | "string" | "cset" | "real") then { - in := name[1] - EvGet(E_Tconv) - pair := in || typecode(&eventvalue) - EvGet(cmask) - case &eventcode of { - E_Sconv: esucctbl[pair] +:= 1 - E_Fconv: efailtbl[pair] +:= 1 - } - } - } - E_Aconv: { - in := typecode(&eventvalue) - EvGet(E_Tconv) - pair := in || typecode(&eventvalue) - EvGet(cmask) - case &eventcode of { - E_Sconv: isucctbl[pair] +:= 1 - E_Fconv: ifailtbl[pair] +:= 1 - } - } - } - } - - cnvlist := sort(esucctbl, 3) - write(output, "\nExplicit successful conversions:\n") - while write(output, get(cnvlist), right(get(cnvlist), 7)) - - cnvlist := sort(efailtbl, 3) - write(output, "\nExplicit failed conversions:\n") - while write(output, get(cnvlist), right(get(cnvlist), 7)) - - cnvlist := sort(isucctbl, 3) - write(output, "\nImplicit successful conversions:\n") - while write(output, get(cnvlist), right(get(cnvlist), 7)) - - cnvlist := sort(ifailtbl, 3) - write(output, "\nImplicit failed conversions:\n") - while write(output, get(cnvlist), right(get(cnvlist), 7)) - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end diff --git a/ipl/mprogs/cvtsum.icn b/ipl/mprogs/cvtsum.icn deleted file mode 100644 index 9e6dfc8..0000000 --- a/ipl/mprogs/cvtsum.icn +++ /dev/null @@ -1,79 +0,0 @@ -############################################################################ -# -# File: cvtsum.icn -# -# Subject: Program to count conversion event tuples -# -# Author: Ralph E. Griswold -# -# Date: November 25, 1996 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program counts conversion events that occur during the monitoring -# of Icon program execution. -# -############################################################################ -# -# Requires: MT Icon and event monitoring -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link numbers -link typecode - -$include "evdefs.icn" - -procedure main(args) - local counts, total, futile, triple, target, value, failure - - EvInit(args) - - counts := table(0) - total := -1 # account for first vacuous entry - futile := 0 - failure := 0 - - while EvGet(ConvMask) do - case &eventcode of { - E_Aconv: { - total +:= 1 - if total % 1000 = 0 then writes(&errout, ".") - counts[triple] +:= 1 - target := typecode(&eventvalue) - triple := target - } - E_Tconv: { - value := typecode(&eventvalue) - if value == target then futile +:= 1 - triple ||:= value - } - E_Nconv: triple ||:= " S" - E_Sconv: triple ||:= " S" - E_Fconv: { - failure +:= 1 - triple ||:= " F" - } - default: stop("*** illegal event code") - } - - delete(counts,&null) - - counts := sort(counts, 3) - - while write(get(counts), right(get(counts),6)) - - write("\ntotal = ",total,"\n") - write(fix(futile / real(total), .01, 3, 2),"% futile") - write(fix(failure / real(total), .01, 3, 2),"% failed") - -end diff --git a/ipl/mprogs/events.icn b/ipl/mprogs/events.icn deleted file mode 100644 index 624c1cb..0000000 --- a/ipl/mprogs/events.icn +++ /dev/null @@ -1,59 +0,0 @@ -############################################################################ -# -# File: events.icn -# -# Subject: Program to show events -# -# Author: Ralph E. Griswold -# -# Date: September 20, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program lists the events that occur in the execution of the icode -# file given as the first argument on the command line. Any other command- -# line arguments are passed to the icode file. -# -# The image of the event code is given in the first column, its -# description is given in the second column, and an image of the -# event value is given in the third column. -# -# The following option is supported: -# -# -o s direct output to file named s; default &output -# -############################################################################ -# -# Requires: MT-Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, evnames, evsyms, options -# -############################################################################ - -link evinit -link evnames -link evsyms -link options - -procedure main(args) - local opts, output, symmap - - symmap := evsyms() - - opts := options(args, "o:") - output := open(\opts["o"], "w") | &output - - EvInit(args) | stop("*** cannot open icode file ***") - - - while EvGet() do - write(output, left(\symmap[&eventcode], 14), - left(evnames(&eventcode), 35), image(&eventvalue)) - -end diff --git a/ipl/mprogs/evstream.icn b/ipl/mprogs/evstream.icn deleted file mode 100644 index 4773b40..0000000 --- a/ipl/mprogs/evstream.icn +++ /dev/null @@ -1,60 +0,0 @@ -############################################################################ -# -# File: evstream.icn -# -# Subject: Program to show events -# -# Author: Ralph E. Griswold -# -# Date: June 8, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program lists the events that occur in the execution of the icode -# file given as the first argument on the command line. Any other command- -# line arguments are passed to the icode file. -# -# The image of the event code is given in the first column, its -# description is given in the second column, and an image of the -# event value is given in the third column. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, evnames, convert -# -############################################################################ - -link evinit -link evnames -link convert - -procedure main(args) - local name - - EvInit(args) | stop("*** cannot open icode file ***") - - name := evnames() - - while EvGet() do - write(left(rimage(&eventcode), 8), - left(\name[&eventcode] | "unknown event",35), image(&eventvalue)) - -end - -procedure rimage(s) - local i - - i := ord(s) - - if 32 <= i <= 126 then return image(s) - else return "\"\\" || exbase10(i, 8) || "\"" - -end diff --git a/ipl/mprogs/evsum.icn b/ipl/mprogs/evsum.icn deleted file mode 100644 index c5cf228..0000000 --- a/ipl/mprogs/evsum.icn +++ /dev/null @@ -1,107 +0,0 @@ -############################################################################ -# -# File: evsum.icn -# -# Subject: Program to tabulate event codes -# -# Author: Ralph E. Griswold -# -# Date: March 26, 2002 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates event codes. It is called as -# -# evsum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -m s sets the event mask named s. If no mask is specified, all -# events are tabulated. (See evdefs.icn for a list of event -# mask names.) -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, evnames, numbers, options -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link evnames -link numbers -link options - -$include "evdefs.icn" - -procedure main(args) - local summary, total, i, subscr, opts, mask, output, alltotal - local itime - - opts := options(args, "m:o:t") - - mask := &cset - mask := case \opts["m"] of { - "AllocMask": AllocMask - "AssignMask": AssignMask - "TypeMask": TypeMask - "ConvMask": ConvMask - "ProcMask": ProcMask - "FncMask": FncMask - "OperMask": OperMask - "ListMask": ListMask - "RecordMask": RecordMask - "ScanMask": ScanMask - "SetMask": SetMask - "TableMask": TableMask - "StructMask": StructMask - default: stop("*** invalid event mask name") - } - - output := open(\opts["o"], "w") | &output - - if \opts["t"] then itime := &time - - EvInit(args) | stop("*** cannot load program") # initialize interface - - summary := table(0) - total := 0 - - while EvGet(mask) do - summary[&eventcode] +:= 1 - - every total +:= !summary - alltotal := total - total /:= 100.0 - - summary := sort(summary, 4) - - write(output, left("event",45), right("count",9), right("percent",10)) - write(output) - while i := pull(summary) do - write(output, left(evnames(pull(summary)), 45), - right(i, 9), " ", fix(i, total, 5, 2)) - - write(output, "\n", left("total:", 45), right(alltotal, 9)) - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end diff --git a/ipl/mprogs/exprsum.icn b/ipl/mprogs/exprsum.icn deleted file mode 100644 index 802d3b6..0000000 --- a/ipl/mprogs/exprsum.icn +++ /dev/null @@ -1,162 +0,0 @@ -############################################################################ -# -# File: exprsum.icn -# -# Subject: Program to tabulate operator and function evaluation -# -# Author: Ralph E. Griswold -# -# Date: February 20, 1995 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates operator and function activity. It is called as -# -# exprsum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: Version 9 MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, evnames, options, procname -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evaltree # maintenance of call tree -link evinit # event monitoring initialization -link evnames # mapping of events to names -link options # command-line options -link procname # string name for procedure - -$include "evdefs.icn" # event code and mask definitions - -global callcount -global calltbl -global failtbl -global namemap -global names -global output -global remvtbl -global resmtbl -global retntbl -global susptbl - -$define NameColumn 14 -$define ValueColumn 10 - -procedure main(args) - local opts, itime - - namemap := evnames() - - opts := options(args, "o:t") - - output := open(\opts["o"], "w") | &output - if \opts["t"] then itime := &time - - # Load and initialize the source program. - - EvInit(args) | stop("*** cannot load source program") - - # Assign tables to for the various kinds of activity. - - every calltbl | retntbl | susptbl | failtbl | resmtbl | remvtbl := table(0) - - # Process the events using the procedure note(). - - evaltree(FncMask ++ OperMask, note) - - # Format the results. - - format(output) - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end - -procedure format(output) - - write(output, - left("name", NameColumn), - right("calls", ValueColumn), - right("returns", ValueColumn), - right("suspends", ValueColumn), - right("failures", ValueColumn), - right("resumps", ValueColumn), - right("removals", ValueColumn) - ) - write(output) - - # sort names by number of calls - - names := sort(calltbl, 4) - - while callcount := pull(names) do { - name := pull(names) - write(output, - left(name, NameColumn), - right(callcount, ValueColumn), - right(retntbl[name], ValueColumn), - right(susptbl[name], ValueColumn), - right(failtbl[name], ValueColumn), - right(resmtbl[name], ValueColumn), - right(remvtbl[name], ValueColumn) - ) - } - - write(output, - "\n", - left("total", NameColumn), - right(tblsum(calltbl), ValueColumn), - right(tblsum(retntbl), ValueColumn), - right(tblsum(susptbl), ValueColumn), - right(tblsum(failtbl), ValueColumn), - right(tblsum(resmtbl), ValueColumn), - right(tblsum(remvtbl), ValueColumn) - ) - -end - -procedure note(new, old) - - case &eventcode of { - !CallCodes: calltbl[procname(new.node, 1)] +:= 1 - !ReturnCodes: retntbl[procname(old.node, 1)] +:= 1 - !SuspendCodes: susptbl[procname(old.node, 1)] +:= 1 - !FailCodes: failtbl[procname(old.node, 1)] +:= 1 - !ResumeCodes: resmtbl[procname(new.node, 1)] +:= 1 - !RemoveCodes: remvtbl[procname(old.node, 1)] +:= 1 - } - - return - -end - -procedure tblsum(tbl) - local count - - count := 0 - every count +:= !tbl - - return count - -end diff --git a/ipl/mprogs/listev.icn b/ipl/mprogs/listev.icn deleted file mode 100644 index 6372ac0..0000000 --- a/ipl/mprogs/listev.icn +++ /dev/null @@ -1,46 +0,0 @@ -############################################################################ -# -# File: listev.icn -# -# Subject: Program to list events -# -# Author: Ralph E. Griswold -# -# Date: August 16, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program list events. Event information is written -# by using image(). -# -# This program is called as -# -# listev tp args -# -############################################################################ -# -# Requires: Version 9.0 MT Icon with event monitoring -# -############################################################################ -# -# Links: evinit, options -# -############################################################################ - -$include "etdefs.icn" - -link evinit -link options - -procedure main(args) - - EvInit(args) | stop("*** cannot load TP") - - while EvGet(T_Mask1) do - write(image(&eventcode), " : ", image(&eventvalue)) - -end diff --git a/ipl/mprogs/locus.icn b/ipl/mprogs/locus.icn deleted file mode 100644 index 8e1581a..0000000 --- a/ipl/mprogs/locus.icn +++ /dev/null @@ -1,126 +0,0 @@ -############################################################################ -# -# File: locus.icn -# -# Subject: Program to trace execution locus -# -# Author: Ralph E. Griswold -# -# Date: March 4, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program traces the locus of program execution. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: em_setup, evinit, xcompat, wopen -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link em_setup -link evinit -link wopen -link xcompat - -global Visualization, Limit - -procedure main(args) - local program_name, Width, Height, x, y, blowup, i, Context, value - local program, line, progarray, Color, ymul, maxheight - local colmask, linemask, mask - - colmask := 2 ^ 16 - linemask := colmask - 1 - - maxheight := 500 - - EvInit(args) | stop("*** cannot load program to monitor") - - program_name := prog_name() - - program := open(program_name) | stop("*** cannot open ", program_name) - - Height := 0 - Width := 0 - - while line := read(program) do { - Height +:= 1 - Width <:= *line - } - - if Height < maxheight / 2 then blowup := 4 - else if Height < maxheight / 4 then blowup := 2 - else blowup := 1 - - progarray := list(Height) - every !progarray := list(Width, 0) - - if Height > maxheight then { - ymul := real(maxheight) / Height - Height := maxheight - } - else ymul := 1 - - Width *:= blowup - Height *:= blowup - - close(program) - - Visualization := WOpen("label=locus", "bg=white", "width=" || Width, - "height=" || Height) | stop("*** cannot open window for visualization") - - Color := list(6) - Color[6] := XBind(Visualization, , "fg=red") - Color[5] := XBind(Visualization, , "fg=orange") - Color[4] := XBind(Visualization, , "fg=yellow") - Color[3] := XBind(Visualization, , "fg=green") - Color[2] := XBind(Visualization, , "fg=blue") - Color[1] := XBind(Visualization, , "fg=gray") - - mask := cset(E_Loc) - - x := y := -10 - - Limit := 10 - i := 0 - - repeat { - - i := (i + 1) % Limit - if i = 0 then { - while *Pending(Visualization) > 0 do - if Event(Visualization) === (&lpress | &mpress | &rpress) then { - event(E_ALoc, (&x / blowup + 1) * colmask + - (&y / blowup) / ymul + 1) - } - } - - EvGet(mask) | break - y := iand(&eventvalue, linemask) - x := &eventvalue / colmask - value := progarray[y, x] +:= 1 - value := integer(log(value, 6)) + 1 - Context := Color[value | *Color] - y := (y * ymul - 1) * blowup - x := (x - 1) * blowup - FillRectangle(Visualization, x, y, blowup, blowup) - FillRectangle(Context, x, y, blowup, blowup) - - } - -end diff --git a/ipl/mprogs/memsum.icn b/ipl/mprogs/memsum.icn deleted file mode 100644 index 95ef2c1..0000000 --- a/ipl/mprogs/memsum.icn +++ /dev/null @@ -1,158 +0,0 @@ -############################################################################ -# -# File: memsum.icn -# -# Subject: Program to tabulate memory allocation -# -# Author: Ralph E. Griswold -# -# Date: August 17, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates storage allocation. It is called as -# -# memsum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, evnames, numbers, options -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link evnames -link numbers -link options - -$include "evdefs.icn" - -global highlights, alloccnt, alloctot, collections, output - -procedure main(args) - local opts, itime, mask - - opts := options(args, "to:") - output := open(\opts["o"], "w") | &output - if \opts["t"] then itime := &time - - EvInit(args) | stop("*** cannot load program") # initialize interface - - alloccnt := table(0) # count of allocations - alloctot := table(0) # total allocation - collections := table(0) # garbage collection counts - - # Be sure all allocation types are listed even if there is no allocation - # for them. - - every alloccnt[!AllocMask] := 0 - every alloctot[!AllocMask] := 0 - - mask := AllocMask ++ E_Collect - - while EvGet(mask) do - if &eventcode === E_Collect then collections[&eventvalue] +:= 1 - else { - alloccnt[&eventcode] +:= 1 - alloctot[&eventcode] +:= &eventvalue - } - - report() - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end - -# Display a table of allocation data -# -procedure report() - local i, cnttotal, tottotal, cnt, tot, totalcoll - - static col1, col2, gutter # column widths - - initial { - col1 := 20 # name field - col2 := 10 # number field - gutter := " " - } - - write(output, "\n", # write column headings - left("type",col1), right("number",col2), gutter, - right("bytes",col2), gutter, right("average",col2), gutter, - right("% bytes",col2), "\n" - ) - - alloccnt := sort(alloccnt, 3) # get the data - alloctot := sort(alloctot, 3) - - cnttotal := 0 - tottotal := 0 - - every i := 2 to *alloccnt by 2 do { - cnttotal +:= alloccnt[i] - tottotal +:= alloctot[i] - } - - while write(output, # write the data - left(name(get(alloccnt)), col1), - right(cnt := get(alloccnt), col2), gutter, - get(alloctot) & right(tot := get(alloctot), col2), gutter, - fix(tot, cnt, col2, 2) | right("0.00", col2), gutter, - fix(100.0 * tot, tottotal, col2, 2) | right("0.00", col2) - ) - - write(output, "\n", # write totals - left("total:",col1), right(cnttotal,col2), gutter, right(tottotal,col2), - gutter, fix(tottotal,cnttotal,col2) | repl(" ",col2) - ) - - totalcoll := 0 # garbage collections - every totalcoll +:= !collections - write(output,"\n",left("collections:",col1),right(totalcoll,col2)) - if totalcoll > 0 then { - write(output,left(" static region:",col1),right(collections[1],col2)) - write(output,left(" string region:",col1),right(collections[2],col2)) - write(output,left(" block region:",col1),right(collections[3],col2)) - write(output,left(" no region:",col1),right(collections[0],col2)) - } - - return -end - -# Produce event name -# -procedure name(code) - local result - - result := evnames(code) - - result ?:= tab(find(" allocation")) - - result ?:= { - tab(find("trapped variable")) || "tv" - } - - return result - -end diff --git a/ipl/mprogs/mmm.icn b/ipl/mprogs/mmm.icn deleted file mode 100644 index a9688cd..0000000 --- a/ipl/mprogs/mmm.icn +++ /dev/null @@ -1,139 +0,0 @@ -############################################################################ -# -# File: mmm.icn -# -# Subject: Program to show allocation as a miniature "MemMon" -# -# Author: Clinton Jeffery -# -# Date: August 12, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# Displays a tiny rendition of internal heap allocation. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: evinit, options, optwindw, typebind, colormap, wipe, xcompat -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link evinit -link options -link optwindw -link typebind -link colormap -link wipe -link xcompat - -global Visualization, contexts -global t, sum, threesixty, wid, hei - -procedure main(av) - local c_string, lines, mymask, allocstr, blockall, sum1, sum2, row1, row2, - Regions, c, start, sum2div4, verbose - if *av>0 then - EvInit(av) | stop("EvInit() can't load ",av[1]) - else - EvInit() | stop("can't EvInit()") - - threesixty := 360 * 64 - t := options(av) - /t["W"] := 650 - /t["H"] := 50 - &window := optwindow(t) | stop("no window") - Visualization := &window - contexts := itypebind(&window) - c_string := contexts[E_String] | stop("eh?") - / contexts[E_Tvsubs] := c_string - - wid := WAttrib("width") - hei := WAttrib("height") - lines := WAttrib("lines") - - mymask := AllocMask ++ cset("\360"||E_Collect||E_BlkDeAlc||E_StrDeAlc) - allocstr := string(AllocMask) - blockall := 0 - - sum1 := 0 - sum2 := 0 - row1 := 0 - row2 := hei/2+1 - - Regions := [] - every put(Regions,keyword("regions",EventSource)) - pop(Regions) - - while EvGet(mymask) do { - if &eventcode === E_Lelem then &eventcode := E_List - if &eventcode === (E_Telem|E_Tvtbl|E_Slots) then &eventcode := E_Table - if &eventcode === E_Selem then &eventcode := E_Set - if &eventcode === E_Refresh then &eventcode := E_Coexpr - case &eventcode of { - E_Collect: { - wipe(&window) - sum1 := sum2 := 0 - row1 := 0 - row2 := hei/2+1 - } - E_EndCollect: { - } - E_String: { - DrawLine(c_string,sum1/4,row1,(sum1+&eventvalue)/4,row1) - sum1 +:= &eventvalue - while sum1/4 >= wid do { - sum1 -:= wid * 4 - row1 +:= 1 - if row1 > hei/2 then { - EraseArea(0,0,wid,hei/2) - row1 := 0 - } - DrawLine(c_string,0,row1,sum1/4,row1) - } - } - !.allocstr: { - c := \contexts[&eventcode] | stop("what is ",&eventcode) - start := sum2/4 - sum2 +:= &eventvalue - sum2div4 := sum2/4 - DrawLine(c,start,row2,sum2div4,row2) - while sum2div4 >= wid do { - sum2 -:= wid * 4 - sum2div4 := sum2/4 - row2 +:= 1 - DrawLine(c,0,row2,sum2div4,row2) - } - } - default: { - if \verbose then write("unknown event code ",&eventcode) - } - } - } - -end - -procedure itypebind(z) - static t - initial { - t := table() - } - /(t[z]):=typebind(z,E_Integer||E_Real||E_Record||E_Set||E_String||E_Cset|| - E_File||E_List||E_Null||E_Proc||E_Table,table()) -# if type(t[z][E_Proc])=="file" then close(t[z][E_Proc]) - t[z][E_Proc] := XBind(z,"fg=#999") - return t[z] -end diff --git a/ipl/mprogs/mtutils.icn b/ipl/mprogs/mtutils.icn deleted file mode 100644 index 3fe42ac..0000000 --- a/ipl/mprogs/mtutils.icn +++ /dev/null @@ -1,40 +0,0 @@ -############################################################################ -# -# File: mtutils.icn -# -# Subject: Program fpr MT Icon -# -# Author: Ralph E. Griswold -# -# Date: March 3, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# Utility procedures for use with MT Icon programs (threads) -# -############################################################################ -# -# Requires: MT Icon -# -############################################################################ - -procedure root() - - C := &main - - while C := parent(C) - - return C - -end - -procedure main() - - if root(&main) === &main then write("safe to talk") - else write("someone may be listening") - -end diff --git a/ipl/mprogs/napoleon.icn b/ipl/mprogs/napoleon.icn deleted file mode 100644 index 026a2ea..0000000 --- a/ipl/mprogs/napoleon.icn +++ /dev/null @@ -1,168 +0,0 @@ -############################################################################ -# -# File: napoleon.icn -# -# Subject: Program to track memory usage by type -# -# Author: Clinton Jeffery -# -# Date: August 12, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# Displays an animated chart showing recent memory usage by Icon type. -# -# Currently not interactive, hence, keys and clicks don't do anything. -# Resizes are handled. -# -# usage: napoleon [-r | -c] prog [args...] -# -# -r provides a regions view, separating the string and block regions -# and displaying memory quantities proportional to the total region size -# rather than the total amount allocated -# -# -c provides continuous updates on each allocation, instead of updating -# only when a change is significant (i.e. when proportions change by >= 1%). -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: evinit, options, optwindw, typebind -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link evinit -link options -link optwindw -link typebind - -global Visualization, contexts -global t, sum, wid, hei, realhei, x, optable - -procedure main(av) - local lines, mymask, allocstr, p, update, e - optable := options(av,"c!r!") - - if *av>0 then - EvInit(av) | stop("EvInit() can't load ",av[1]) - else - EvInit() | stop("can't EvInit()") - - /optable["W"] := 100 - /optable["H"] := 400 - &window := optwindow(optable) | stop("no window") - - Visualization := &window - contexts := typebind(&window,E_Integer||E_Real||E_Record||E_Set||E_String|| - E_Cset||E_File||E_List||E_Null||E_Proc||E_Table|| - E_Tvsubs, table()) - - wid := WAttrib("width") - hei := WAttrib("height") - realhei := real(hei) - if \optable["r"] then { - realhei /:= 2 - sum := 65000 - } - else { - sum := 0 - } - - lines := WAttrib("lines") - - mymask := AllocMask ++ cset(E_EndCollect||E_Collect) - allocstr := string(AllocMask) - - t := table(0.0) - p := table(0) - - update := 1 - - while EvGet(mymask) do { - if &eventcode === E_Lelem then &eventcode := E_List - if &eventcode === (E_Telem|E_Tvtbl|E_Slots) then &eventcode := E_Table - if &eventcode === E_Selem then &eventcode := E_Set - if &eventcode === E_Refresh then &eventcode := E_Coexpr - case &eventcode of { - E_Collect: { - EraseArea(x,0) - every !t := 0.0 - if /optable["r"] then sum := 0 - update := &null - } - E_EndCollect: { - update := 1 - if sum=0 then sum := 1 - redraw() - } - !.allocstr: { - t[&eventcode] +:= &eventvalue - if /optable["r"] then sum +:= &eventvalue - if \optable["c"] | - p[&eventcode] ~=:= integer(t[&eventcode] / (0<sum) * 100) then { - if \update then redraw() - } - } - default: { - write("unknown event code ",&eventcode) - } - } - if Pending()[1] then { - e := Event() - case e of { - &resize: { - wid := &x - hei := &y - EraseArea() - realhei := real(hei) - if \optable["r"] then { - realhei /:= 2 - } - if \update then redraw() - } - } - } - } - EvTerm() - close(&window) -end - -procedure redraw() - local start, fract, k, path - initial { - x := 0 - } - if \optable["r"] then - start := integer(realhei) - else - start := 0 - fract := realhei / sum - every k := key(t) do { - path := fract * t[k] - if \optable["r"] & k==E_String then - FillRectangle(\contexts[k]|Visualization, x, 0, 1, path) - else { - FillRectangle(\contexts[k]|Visualization, x, start, 1, path) - start +:= path - } - } - x +:= 1 - if x > wid then { - x := 0 - EraseArea(0,0,5) - } - EraseArea(x+3,0,1) -end diff --git a/ipl/mprogs/novae.icn b/ipl/mprogs/novae.icn deleted file mode 100644 index 71cd5d3..0000000 --- a/ipl/mprogs/novae.icn +++ /dev/null @@ -1,93 +0,0 @@ -############################################################################ -# -# File: novae.icn -# -# Subject: Program to show allocations as exploding stars -# -# Author: Ralph E. Griswold -# -# Date: June 25, 1996 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program shows allocation on two stars with radiating lines -# -# The tool-specific options are: -# -# -h i Height of panel, default 300 -# -w i Width of one panel, default 300 -# -s i number of lines, default 360 -# -d draw dot at end of line instead of full line -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: em_setup, visprocs -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link em_setup -link visprocs - -$define Height 300 -$define Width 300 -$define Sectors 360 - -procedure main(args) - local clear, sdegrees, bdegrees - local degrees, arc, advance, fullcircle - local xorg, yorg, radius, radians, dots, sxorg, syorg, bxorg, byorg - - em_setup(args) - - fullcircle := 360 - sdegrees := bdegrees := 0 - radians := 0 - advance := fullcircle / Sectors # amount to advance - - sxorg := integer(Width / 2.0) - syorg := (Height / 2.0) - bxorg := sxorg + Width - byorg := syorg - radius := ((Height < Width) | Height) / 2.0 - - vis_setup("label=novae", "size=" || (2 * Width) || "," || Height, - "bg=black") - - Context := context_setup(AllocMask) - - while EvGet(AllocMask) do { - if &eventcode === E_String then { - xorg := sxorg - yorg := syorg - sdegrees +:= advance - sdegrees %:= fullcircle - radians := -dtor(sdegrees) - } - else { - xorg := bxorg - yorg := byorg - bdegrees +:= advance - bdegrees %:= fullcircle - radians := -dtor(bdegrees) - } - DrawLine(Context[&eventcode], xorg, yorg, &eventvalue * cos(radians) + - xorg, &eventvalue * sin(radians) + yorg) - } - - em_end() - -end diff --git a/ipl/mprogs/numsum.icn b/ipl/mprogs/numsum.icn deleted file mode 100644 index f08f15e..0000000 --- a/ipl/mprogs/numsum.icn +++ /dev/null @@ -1,103 +0,0 @@ -############################################################################ -# -# File: numsum.icn -# -# Subject: Program to tabulate numerical computation -# -# Author: Ralph E. Griswold -# -# Date: September 20, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates numerical-computation activity. It is called as -# -# numsum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, options, procname -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link options -link procname - -$include "evdefs.icn" - -procedure main(args) - local opts, itime, output, inttbl, reltbl, cmask, rmask, numlist, op - local pos, neg, plus, minus, mpy, div, pwr, mod, count - - opts := options(args, "o:t") - - output := open(\opts["o"], "w") | &output - - if \opts["t"] then itime := &time - - EvInit(args) | stop("*** cannot load program") # initialize interface - - inttbl := table(0) - reltbl := table(0) - - cmask := E_Fcall ++ E_Ocall - rmask := E_Fret ++ E_Oret ++ E_Ffail ++ E_Ofail - - pos := proc("+", 1) - neg := proc("-", 1) - plus := proc("+", 2) - minus := proc("-", 2) - mpy := proc("*", 2) - div := proc("/", 2) - mod := proc("%", 2) - pwr := proc("^", 2) - - while EvGet(cmask) do { - if (op := &eventvalue) === ( - plus | minus | mpy | div | neg | pwr | mod | - iand | ior | ixor | icom | ishift | pos - ) then { - EvGet(rmask) - if &eventcode === (E_Ofail | E_Ffail) then next - case type(&eventvalue) of { - "integer": inttbl[op] +:= 1 - "real": reltbl[op] +:= 1 - } - } - } - - write(output, "\nInteger computation:\n") - numlist := sort(inttbl, 4) - while count := pull(numlist) do - write(output, left(procname(pull(numlist)), 6), right(count, 9)) - - write(output, "\nReal computation:\n") - numlist := sort(reltbl, 4) - while count := pull(numlist) do - while write(output, left(procname(pull(numlist)), 6), right(count, 9)) - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end diff --git a/ipl/mprogs/opersum.icn b/ipl/mprogs/opersum.icn deleted file mode 100644 index 3d6ffce..0000000 --- a/ipl/mprogs/opersum.icn +++ /dev/null @@ -1,200 +0,0 @@ -############################################################################ -# -# File: opersum.icn -# -# Subject: Program to tabulate operation activity -# -# Author: Ralph E. Griswold -# -# Date: March 10, 1998 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates operation activity. It is called as -# -# opersum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -m s sets the event mask named s. The supported masks are -# FncMask (the default), OperMask, ProcMask, ScanMask, -# and Oper+Mask, which includes both ScanMask and -# OperMask. -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, evnames, options, procname -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evaltree -link evinit -link evnames -link options -link procname - -$include "evdefs.icn" - -global namemap, output, fncset, scan, fnames, mask -global calltbl, retntbl, susptbl, failtbl, resmtbl, remvtbl - -procedure main(args) - local opts, itime - - namemap := evnames() - - opts := options(args, "m:o:t") - - mask := FncMask - mask := case \opts["m"] of { - "ProcMask": ProcMask - "FncMask": FncMask - "OperMask": OperMask - "ScanMask": { - scan := 1 - ScanMask - } - "Oper+Mask": { - scan := 1 - OperMask ++ ScanMask - } - default: stop("*** invalid event mask name") - } - - if mask === FncMask then { # beware record constructors - fnames := set() # valid function names - every insert(fnames, function() || "()") - } - - output := open(\opts["o"], "w") | &output - - if \opts["t"] then itime := &time - - EvInit(args) | stop("*** cannot load program") # initialize interface - - calltbl := table(0) - retntbl := table(0) - susptbl := table(0) - failtbl := table(0) - resmtbl := table(0) - remvtbl := table(0) - - fncset := set() - - EvInit(args) | stop("*** cannot load program") # initialize interface - - evaltree(mask, note) - - write(output, - left("name", 14), - right("calls", 10), - right("returns", 10), - right("suspends", 10), - right("failures", 10), - right("resumps", 10), - right("removals", 10) - ) - write(output) - - every name := !sort(fncset) do - write(output, - left(name, 14), - right(calltbl[name], 10), - right(retntbl[name], 10), - right(susptbl[name], 10), - right(failtbl[name], 10), - right(resmtbl[name], 10), - right(remvtbl[name], 10) - ) - - write(output, - "\n", - left("total", 14), - right(tblsum(calltbl), 10), - right(tblsum(retntbl), 10), - right(tblsum(susptbl), 10), - right(tblsum(failtbl), 10), - right(tblsum(resmtbl), 10), - right(tblsum(remvtbl), 10) - ) - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end - -procedure note(new, old) - - case &eventcode of { - !CallCodes: { - name := ename(new.node) - if (mask === FncMask) & not(member(fnames, name)) then return - calltbl[name] +:= 1 - insert(fncset, name) - } - !ReturnCodes: { - name := ename(old.node) - if (mask === FncMask) & not(member(fnames, name)) then return - retntbl[name] +:= 1 - } - !SuspendCodes: { - name := ename(old.node) - if (mask === FncMask) & not(member(fnames, name)) then return - susptbl[name] +:= 1 - } - !FailCodes: { - name := ename(old.node) - if (mask === FncMask) & not(member(fnames, name)) then return - failtbl[name] +:= 1 - } - !ResumeCodes: { - name := ename(new.node) - if (mask === FncMask) & not(member(fnames, name)) then return - resmtbl[name] +:= 1 - } - !RemoveCodes: { - name := ename(old.node) - if (mask === FncMask) & not(member(fnames, name)) then return - remvtbl[name] +:= 1 - } - } - - return - -end - -procedure ename(x) - if /x then return "bogon" - else if \scan & not(proc(x)) then return "e1 ? e2" - else return procname(x, 1) # use the expanded form - -end - -procedure tblsum(tbl) - local count - - count := 0 - - every count +:= !tbl - - return count - -end diff --git a/ipl/mprogs/ostrip.icn b/ipl/mprogs/ostrip.icn deleted file mode 100644 index 44091a5..0000000 --- a/ipl/mprogs/ostrip.icn +++ /dev/null @@ -1,71 +0,0 @@ -############################################################################ -# -# File: ostrip.icn -# -# Subject: Program to show virtual-machine op-code strip -# -# Author: Ralph E. Griswold -# -# Date: March 26, 2002 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program produces a listing of virtual machine codes and the events -# that occur between them. -# -# The following option is supported: -# -# -o s direct output to file s; default &output -# -############################################################################ -# -# Requires: MT Icon and event monitoring -# -############################################################################ -# -# Links: evinit, evsyms, opnames, options -# -############################################################################ - -link evinit -link evsyms -link opnames -link options - -$include "evdefs.icn" - -procedure main(args) - local codes, esmap, opmap, opcode, opts, output - - opts := options(args, "o:") - output := open(\opts["o"], "w") | &output - - EvInit(args) | stop("*** cannot load SP") - - opmap := opnames() - esmap := evsyms() - - opcode := cset(E_Opcode) - - while EvGet(opcode) do { # get to first "real" op-code - if opmap[integer(&eventvalue)] == "Invoke" then { - writes(output, "Invoke |") - break() - } - } - - while EvGet() do { - if &eventcode === E_Opcode then { - write(output) - writes(output, left(opmap[integer(&eventvalue)], 10), "|") - } - else writes(output, " ", esmap[&eventcode]) - } - - write(output) - -end diff --git a/ipl/mprogs/playev.icn b/ipl/mprogs/playev.icn deleted file mode 100644 index 7fdf595..0000000 --- a/ipl/mprogs/playev.icn +++ /dev/null @@ -1,59 +0,0 @@ -############################################################################ -# -# File: playev.icn -# -# Subject: Program to play back events -# -# Author: Ralph E. Griswold -# -# Date: August 16, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program plays back events saved by recordev. Since recordev -# uses image() for recording, some information may be lost. -# -# This program is called as -# -# playev em <history -# -# where history is a file produced by recordev. -# -############################################################################ -# -# Requires: Version 9.0 MT Icon with event monitoring -# -############################################################################ -# -# Links: evinit, ivalue -# -############################################################################ - -link evinit -link ivalue - -procedure main(args) - local mask, prog - - prog := load(pop(args), args) | stop("*** cannot EM") - - variable("&eventsource", prog) := ¤t | stop("no eventsource?") - - mask := @prog # activate EM to get its mask - - while &eventcode := read() do { - &eventcode := ivalue(&eventcode) # can fail - &eventvalue := read() | break - if find(&eventcode, mask) then { - &eventvalue := ivalue(&eventvalue) # can fail - mask := event(, , prog) # pass event; get mask back - } - } - - cofail(prog) - -end diff --git a/ipl/mprogs/program.icn b/ipl/mprogs/program.icn deleted file mode 100644 index ad32344..0000000 --- a/ipl/mprogs/program.icn +++ /dev/null @@ -1,138 +0,0 @@ -############################################################################ -# -# File: program.icn -# -# Subject: Program to display portion of a program in a window -# -# Author: Ralph E. Griswold -# -# Date: February 28, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program views the text of a program through a window. The image -# of the program is maintained in a pixmap. Positioning the desired -# portion of the program amounts to copying the appropriate portion -# of the pixmap to the window. -# -# The pixmap has half a window's white space at the top and at the -# bottom to that the beginning and ends of a program can be shown -# using the same logic as for interior portions of the program. -# -# The program is written as a visual monitor to run under the control -# of another program, such as Eve. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: basename, em_setup, filedim -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link basename -link em_setup -link filedim - -global Visualization, textmap, twidth, wheight, oheight, hsize, ncols -global highlight - -procedure main(args) - local vrows, SourceFile, size, mrows, mcols - local input, line_no, cwidth, x, colmask, column - local xwidth, wwidth, maxcols, linemask, line, i - - colmask := 2 ^ 16 - linemask := colmask - 1 - - em_setup(args) - - vrows := 10 # ad hoc for now - ncols := 6 # ditto - maxcols := 85 # ditto - - hsize := 4 - - SourceFile := prog_name() - - size := filedim(SourceFile) - - mrows := vrows + size.rows # white space at top and bottom - mcols := size.cols - mcols >:= maxcols - mcols +:= ncols + 1 # space for line numbers and bar - -# Now create hidden canvases for the program and identifying line numbers. - - textmap := WOpen("canvas=hidden", "lines=" || mrows, - "columns=" || mcols) | stop("*** cannot hidden canvas for program") - - twidth := WAttrib(textmap, "width") - oheight := (WAttrib(textmap, "height") / mrows) / 2 + (hsize / 2) - -# Set positions in the pixmaps to leave space at the top and the bottom. - - GotoRC(textmap, vrows / 2, 1) - -# Put the text of the program into the canvas, while adding line -# numbers to the other canvas. - - input := open(SourceFile) | stop("*** cannot open ", SourceFile) - - line_no := 0 - - while write(textmap, right(line_no +:= 1, ncols - 1), " ", read(input)) - -# Draw a line in linemap to separate the line numbers from the -# program text when they get copied into the window. - - cwidth := TextWidth(textmap, repl("x", ncols + 1)) - x := cwidth - (cwidth / (2 * (ncols))) - 5 - - DrawLine(textmap, x, 0, x, WAttrib(textmap, "height")) - - vis_setup("label=" || basename(SourceFile), "lines=" || vrows, - "columns=80") - - highlight := Clone(Visualization, "fg=red") - - wwidth := WAttrib(Visualization, "width") - wheight := WAttrib(Visualization, "height") - - focus(1, 0) # start-up view - - while EvGet('', 1) do - if &eventcode === E_ALoc then { - line := iand(&eventvalue, linemask) - 1 # for positioning - column := &eventvalue / colmask - focus(line, column) - } - -end - -procedure focus(line, column) - local x, y - - y := (line - 1) * WAttrib("leading") # for positioning - CopyArea(textmap, Visualization, 0, y, twidth, wheight) - FillRectangle(highlight, 2, y := wheight / 2 - oheight, hsize, hsize) - if column > 0 then { - x := (column + ncols + 1) * WAttrib("fwidth") - FillRectangle(highlight, x, y + 10, 6, 1) - } - - return - -end diff --git a/ipl/mprogs/recordev.icn b/ipl/mprogs/recordev.icn deleted file mode 100644 index 4ad0f8f..0000000 --- a/ipl/mprogs/recordev.icn +++ /dev/null @@ -1,69 +0,0 @@ -############################################################################ -# -# File: recordev.icn -# -# Subject: Program to record events -# -# Author: Ralph E. Griswold -# -# Date: August 16, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program records events in a file. Event information is stored -# by using image(), so some information may be lost. -# -# This program is called as -# -# recordev <options> tp args -# -# The options supported are: -# -# -o s write event history to the file named s; default standard -# output. -# -# -c s prefix the event history with a comment event whose value -# is s. -# -# Warning: If -o is not given and tp also writes to standard output, -# the event history file will be corrupted. -# -# If args contains options, use -- to prevent recordev from consuming them, -# as in -# -# recordev -o history -- tp args -# -############################################################################ -# -# Requires: Version 9.0 MT Icon with event monitoring -# -############################################################################ -# -# Links: evinit, options -# -############################################################################ - -link evinit -link options - -procedure main(args) - local file, output, opts - - opts := options(args, "c:o:") - if file := \opts["o"] then { - output := open(file, "w") | stop("*** cannot open ", image(file)) - } - else output := &output - - write(output, image("#"), "\n", image(\opts["c"])) - - EvInit(args) | stop("*** cannot load TP") - - while EvGet() do - write(output, image(&eventcode), "\n", image(&eventvalue)) - -end diff --git a/ipl/mprogs/roll.icn b/ipl/mprogs/roll.icn deleted file mode 100644 index 0f1ea32..0000000 --- a/ipl/mprogs/roll.icn +++ /dev/null @@ -1,103 +0,0 @@ -############################################################################ -# -# File: roll.icn -# -# Subject: Program to display the program counter on a stripchart -# -# Author: Gregg M. Townsend and Ralph E. Griswold -# -# Date: June 25, 1996 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# roll displays a chart recording a time-history of program execution -# by line number. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: em_setup, filedim, strpchrt -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link em_setup -link filedim -link strpchrt - -$define Width 500 -$define MaxHeight 500 - -global ifile, Limit -global maxln - -procedure main(args) - local fname, sc, h, t, y, mask, ymul, maxln - local size, i, linemask - - linemask := 2 ^ 16 - 1 - - em_setup(args) - - size := filedim(prog_name()) - maxln := size.rows - - if maxln > MaxHeight then { - ymul := real(MaxHeight) / maxln - maxln := MaxHeight - } - else ymul := 1 - - Limit := 10 - - vis_setup("size=" || Width || "," || maxln, "label=roll") - - sc := stripchart(Visualization, 0, 0, Width, maxln) - - t := 0 - i := 0 - - mask := E_Loc ++ E_Tick - - repeat { - - i := (i + 1) % Limit - - if i = 0 then { - while *Pending(Visualization) > 0 do - case Event(Visualization) of { - &lpress | &mpress | &rpress: { - event(E_ALoc, integer(&y / ymul) + 1, &eventsource) - } - } - } - - - EvGet(mask) | break - if &eventcode === E_Loc then { - y := ymul * iand(&eventvalue, linemask) - DrawPoint(sc.win, sc.x, y) - } - else if &eventcode === E_Tick then sadvance(sc, &eventvalue) - } - - sadvance(sc) - - Fg(sc.win, "red") - DrawLine(sc.win, sc.x, 0, sc.x, maxln) - - em_end() - -end diff --git a/ipl/mprogs/scat.icn b/ipl/mprogs/scat.icn deleted file mode 100644 index 631be9c..0000000 --- a/ipl/mprogs/scat.icn +++ /dev/null @@ -1,143 +0,0 @@ -############################################################################ -# -# File: scat.icn -# -# Subject: Program to produce call/result scatterplot -# -# Author: Clinton Jeffery -# -# Date: November 11, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# Press the left mouse button atop any plotted point to see the list of -# procedures at that point. Execution (and point motion) is suspended -# until the mouse button is released. -# -############################################################################ -# -# Requires: Version 9 graphics -# -############################################################################ -# -# Links: eemutils, vinit -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link emutils -link evinit - -global at, # table of counts of procedures at a given point - call, # table of call counts - rslt # table of result counts - -record activation (p, parent, children) - -procedure main(av) - local mask, maxmax, maxmatch, current_proc, L, max, i, k, child, e - - EvInit(av) | stop("*** cannot load SP") - - kill_output() - - &window := open("scat","x","geometry=150x180") | stop("can't open window") - current_proc := activation(,activation(,,,,[]),[]) - call := table(0) - rslt := table(0) - at := table(0) - mask := ProcMask ++ E_MXevent - maxmax := 0 - maxmatch := 0 - - while EvGet(mask) do { - case &eventcode of { - E_Pcall: { - move(&eventvalue, 1, 0) - current_proc := activation(&eventvalue, current_proc, []) - put(current_proc.parent.children, current_proc) - } - E_Psusp: { - move(current_proc.p, 0, 1) - current_proc := current_proc.parent - } - E_Presum: { - current_proc := current_proc.children[-1] - } - E_Pret: { - move(current_proc.p, 0, 1) - pull(current_proc.parent.children) - current_proc := current_proc.parent - } - E_Pfail: { - pull(current_proc.parent.children) - current_proc := current_proc.parent - } - E_Prem: { - child := pull(current_proc.children) - current_proc.children |||:= child.children - } - E_MXevent: { - case &eventvalue of { - "q" | "\033": stop("terminated") - &lpress | &ldrag : { - repeat { - L := [] - every k := key(call) do { - if -3 < 2*log(call[k]+2,1.25)+2 - &x < 3 & - -3 < 2*log(rslt[k]+2,1.25)+2 - &y < 3 then { - put(L, procedure_name(k)) - } - } - if max := * (L[1]) then { - every max <:= *( !L ) - maxmax <:= max - } - maxmatch <:= *L - &col := WAttrib("columns") - maxmax - &row := WAttrib("lines") - maxmatch - 1 - EraseArea(&x,&y) - if *L > 0 then { - every i := 1 to *L do { - GotoRC(WAttrib("lines")-*L+i,WAttrib("columns")-max) - writes(&window,L[i]) - } - e := Event() - every i := 1 to *L do { - GotoRC(WAttrib("lines")-*L+i,WAttrib("columns")-max) - writes(&window,L[i]) - } - } - else e := Event() - - if e === &lrelease then break - } - } - } - } - } - } - -end - -procedure procedure_name(p) - return image(p) ? { ="procedure "; tab(0) } -end - -procedure move(who, iscall, isrslt) - if (at[integer(2*log(call[who]+2,1.25)) || "," || integer(2*log(rslt[who]+2,1.25))] -:= 1) = 0 then - EraseArea(2*log(call[who]+2,1.25) + 2, 2*log(rslt[who]+2,1.25) + 2, 2, 2) - call[who] +:= iscall - rslt[who] +:= isrslt - if (at[integer(2*log(call[who]+2,1.25)) || "," || integer(2*log(rslt[who]+2,1.25))] +:= 1) = 1 then - FillRectangle(2*log(call[who]+2,1.25) + 2, 2*log(rslt[who]+2,1.25) + 2, 2, 2) -end diff --git a/ipl/mprogs/scater.icn b/ipl/mprogs/scater.icn deleted file mode 100644 index aad7502..0000000 --- a/ipl/mprogs/scater.icn +++ /dev/null @@ -1,183 +0,0 @@ -############################################################################ -# -# File: scater.icn -# -# Subject: Program to display visualize string concatenation -# -# Author: Ralph E. Griswold -# -# Date: March 1, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program displays successive numbers by lines of corresponding -# height. When the display area is full, it scrolls from right to -# left. -# -# In this version, input is piped in. -# -############################################################################ -# -# Requires: Version 9 graphics, MT Icon and instrumentation -# -############################################################################ -# -# Links: evinit, interact, vsetup -# -############################################################################ - -link evinit -link interact -link vsetup - -global vidgets -global root -global strip -global state -global gc_black -global reset -global scale - -global width -global height - -global window - -$include "evdefs.icn" - -procedure main(args) - - init(args) - - display() - -end - -procedure init(args) - - EvInit(args) | stop("*** cannot load SP.") - - /EventSource := &eventsource - - variable("write", EventSource) := -1 - variable("writes", EventSource) := -1 - - window := WOpen ! ui_atts() - - vidgets := ui() - - root := vidgets["root"] - - state := &null - scale := 1 - - width := vidgets["strip"].uw - height := vidgets["strip"].uh - - strip := Clone(window, "dx=" || vidgets["strip"].ux, "dy=" || - vidgets["strip"].uy) - Clip(strip, 0, 0, width, height) - gc_black := Clone(strip, "fg=black") - -end - -procedure display() - static cat, cmask, rmask - - initial { - cat := proc("||", 2) - cmask := cset(E_Ocall) - rmask := cset(E_Oret) - } - - repeat { - while (*Pending() > 0) | \state do - ProcessEvent(root, , shortcuts) - EvGet(cmask) | exit() - if &eventvalue === cat then { - EvGet(rmask) | exit() - &eventvalue := *&eventvalue - &eventvalue *:= scale - &eventvalue >:= height # Motif bug avoidance - CopyArea(strip, 1, 0, width - 1, height, 0, 0) - EraseArea(strip, width - 1, 0, width, height) - DrawLine(gc_black, width - 1, height - &eventvalue, width - 1, height) - } - } - -end - -procedure file_cb(vidget, value) - - case value[1] of { - "snapshot @S": return snapshot(strip, 0, 0, width, height) - "quit @Q": exit() - } - - fail - -end - -procedure configure_cb(vidget, value) - - case value[1] of { - "scale": { - repeat { - if TextDialog(, "scale", scale, 10) == "Okay" then { - scale := (0 < numeric(dialog_value[1])) | { - Notice("Invalid scale value.") - next - } - reset_cb() - return - } - else fail # user canceled - } - } - } - - fail - -end - -procedure reset_cb() - - EraseArea(strip) - - return - -end - -procedure shortcuts(e) - - if &meta then - case map(e) of { - "q": exit() - "s": return snapshot(strip, 0, 0, width, height) - } - else fail - -end - -#===<<vib:begin>>=== modify using vib; do not remove this marker line -procedure ui_atts() - return ["size=477,255", "bg=gray-white"] -end - -procedure ui(win, cbk) -return vsetup(win, cbk, - [":Sizer:::0,0,477,255:",], - ["configure:Menu:pull::36,0,71,21:Configure",configure_cb, - ["scale"]], - ["file:Menu:pull::0,1,36,21:File",file_cb, - ["snapshot @S","quit @Q"]], - ["line1:Line:::0,22,477,22:",], - ["reset:Button:regular::11,76,42,20:reset",reset_cb], - ["strip:Rect:grooved::63,37,400,200:",], - ) -end -#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/mprogs/strsum.icn b/ipl/mprogs/strsum.icn deleted file mode 100644 index 6160b13..0000000 --- a/ipl/mprogs/strsum.icn +++ /dev/null @@ -1,100 +0,0 @@ -############################################################################ -# -# File: strsum.icn -# -# Subject: Program to tabulate string computation -# -# Author: Ralph E. Griswold -# -# Date: August 14, 1994 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates string-computation activity. It is called as -# -# strsum prog -# -# where prog is a program compiled under MT Icon whose events are to -# be tabulated. -# -# The options supported are: -# -# -o s write output to file s; default &output. -# -# -t record time spent in monitoring. -# -############################################################################ -# -# Requires: MT Icon and event monitoring. -# -############################################################################ -# -# Links: evinit, options, procname -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link evinit -link options -link procname - -$include "evdefs.icn" - -procedure main(args) - local opts, itime, output, cnttbl, amttbl, cmask, rmask, numlist, op, cat - local subs - - opts := options(args, "o:t") - - output := open(\opts["o"], "w") | &output - - if \opts["t"] then itime := &time - - EvInit(args) | stop("*** cannot load program") # initialize interface - - cnttbl := table(0) - amttbl := table(0) - - cat := proc("||", 2) - subs := proc("[]", 2) - - cmask := E_Fcall ++ E_Ocall ++ E_Ssasgn - rmask := E_Fret ++ E_Oret - - while EvGet(cmask) do { - case &eventcode of { - E_Fcall | E_Ocall: { - if (op := &eventvalue) === ( - cat | right | left | center | entab | detab | repl | - reverse | map - ) then { - EvGet(rmask) - cnttbl[op] +:= 1 - amttbl[op] +:= *&eventvalue - } - } - E_Ssasgn: { - cnttbl[subs] +:= 1 - amttbl[subs] +:= 1 - } - } - } - - write(output, "\nString operation count:\n") - numlist := sort(cnttbl, 3) - while write(output, left(procname(get(numlist)), 6), right(get(numlist), 8)) - - write(output, "\nString allocation:\n") - numlist := sort(amttbl, 3) - while write(output, left(procname(get(numlist)), 6), right(get(numlist), 8)) - - write(output, "\nelapsed time: ", &time - \itime, "ms") - -end diff --git a/ipl/mprogs/strucget.icn b/ipl/mprogs/strucget.icn deleted file mode 100644 index f06ab44..0000000 --- a/ipl/mprogs/strucget.icn +++ /dev/null @@ -1,68 +0,0 @@ -############################################################################ -# -# File: strucget.icn -# -# Subject: Program to collect SP structures -# -# Author: Ralph E. Griswold -# -# Date: March 26, 2002 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program collects the structures in an SP and when the SP -# terminates, it saves them as an xencoded file. Records are not -# collected because they cannot be decoded in the absence of the -# appropriate record declaration. -# -# By keeping pointers to the structures in an SP, it assures that -# all structures produced by that program are intact at the time -# the SP terminates. Be aware, however, that some structures may -# have been "emptied" by the time the SP terminates, for example, -# by get(L). -# -# Saving the SP structure prevents them from being collected, which may -# affect SP performance or even behavior. -# -# The xencoded file is named <sp>.xcode there <sp> is the name of the -# SP as given on the command line. -# -############################################################################ -# -# Requires: MT Icon and instrumentation -# -############################################################################ -# -# Links: evinit, xcodes -# -############################################################################ - -link evinit -link xcodes - -$include "evdefs.icn" - -procedure main(args) - local mask, structs, name - - name := args[1] | stop("*** no SP") - - EvInit(args) | stop("*** cannot open SP") - - variable("write", &eventsource) := -1 # turn off SP output - variable("writes", &eventsource) := -1 - - structs := set() - - mask := cset(E_Lcreate || E_Rcreate || E_Screate || E_Tcreate) - - while EvGet(mask) do - insert(structs, &eventvalue) # add new structure - - xencoden(sort(structs), name || ".xcode") # save SP structures - -end diff --git a/ipl/mprogs/vc.icn b/ipl/mprogs/vc.icn deleted file mode 100644 index 6e1e5e2..0000000 --- a/ipl/mprogs/vc.icn +++ /dev/null @@ -1,616 +0,0 @@ -############################################################################ -# -# File: vc.icn -# -# Subject: Program to coordinate visualization programs -# -# Author: Ralph E. Griswold -# -# Date: March 1, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This program loads and runs multiple MPs. It is based on the original -# visualization coordinator, Eve, written by Clint Jeffery. -# -# This is a work in progress. At the moment, it works in demonstration -# mode with only hard-coded SPs and MPs available. -# -# The following interface features are provided: -# -# File menu -# -# snapshot @S take snapshot of selected visualization -# quit @Q exit from vc -# -# Pause toggle (@P) to stop and start visualization -# -# Speed control slider for SP events -# -# Display of clock ticks in SP -# -############################################################################ -# -# The following features remain to be implemented: -# -# disabling and enabling MPs -# adding and removing MPs -# specification of SPs and MPs not in hard-coded list -# specification of input data for SPs -# attempt to position MP windows in a useful way -# provide for changing SPs -# provide for continued visualization when SP terminates -# -# Also, there are numerous small problems that need to be fixed, as -# well as better documentation. -# -############################################################################ -# -# Requires: Version 9 MT Icon, event monitoring, and graphics -# -############################################################################ -# -# Links: basename, evutils, interact, lists, vsetup -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -link basename -link evutils -link interact -link lists -link vsetup - -$include "evdefs.icn" - -$define EventIter 10 # number of SP events per check on interface - -$define BlkSize 500000 # region sizes for SP and MPs -$define StrSize 500000 -$define MstkSize 20000 - -$define On 1 # initial selection states for MPs -$define Off &null - -# vc's knowledge about MPs is stored in a list of records of type "mp_rec". - -record mp_rec(name, prog, mask, enabled) - -global mps # list of EMs -global mpath # path to MPs -global spath # path to SPs and data -global pause # pause vidget -global unioncset # union of MPs' csets -global root # root vidget -global EventCodeTable # table of MPs to call for each event -global delayval # amount of delay per event -global candidates # list of potential MPs to run -global ticksum # number of clock ticks elapsed in SP -global vc_handlers # procedures for each event vc handles itself -global vc_queue # queue used for MP-MP communication -global vidgets # table of vidgets -global state # paused/running toggle -global mps_names # MP names -global mps_selected # MPs selected -global program # SP - -global SourceProgram # source-code file for SP -global Coordination # indicate MPs are running under a coordinator - -procedure main() - - init() # initialize interface, SP, and MPs - - run() # process events - -end - -procedure able_mps() - local mp_names, mp_enabled, rec, i - - mp_names := [] - mp_enabled := [] - - every rec := !mps do { - put(mp_names, rec.name) - put(mp_enabled, rec.enabled) - } - - if ToggleDialog("MP state", mp_names, mp_enabled) == - "Cancel" then fail - - every i := 1 to *mps do - mps[i].enabled := dialog_value[i] - - union_mask() - - return - -end - -procedure add_mps() - local i - - if ToggleDialog( "Select monitoring programs:", mps_names, mps_selected) == - "Cancel" then fail - - mps_selected := candidates := dialog_value - - mps := [] - - every i := 1 to *candidates do { - if /candidates[i] then next # skip unselected MPs - else put(mps, mp(mpath || mps_names[i])) - } - - every i := 1 to *mps do - mps[i].mask := @mps[i].prog - - union_mask() - - return - -end - -# broadcast() - send event to interested MPs -# -procedure broadcast(x, except) - - /vc_queue := [] - - put(vc_queue, x, except) - - flush_queue() - - return - -end - -# Write the current elapsed SP clock ticks. -# -procedure drawtime(val) - static odo, odo_x, odo_y - - initial { - odo := vidgets["odometer"] - odo_x := vidgets["odometer"].ax - odo_y := vidgets["odometer"].ay + vidgets["odometer"].ah - 6 - } - - GotoXY(odo_x, odo_y) - WWrites(right(val, 6)) - -end - -# Handle file menu. -# -procedure file_cb(vidget, value) - - case value[1] of { - "quit @Q": exit() - "snapshot @S": snap_view() - } - - return - -end - -# Flush events produced during MP-MP communcation. This code is similar to -# vc's main loop. -# -procedure flush_queue() - local c, mask, x, except, monitor - - while *vc_queue > 0 do { - x := pop(vc_queue) - except := pop(vc_queue) | - ExitNotice("Malformed broadcast queue.") - every monitor := (except ~=== !mps) do - if mask := event( , , monitor.prog) then { - if mask ~=== monitor.mask then { - while type(mask) ~== "cset" do { - # - # An MP (probably) has raised a flag. - # Pass it on to all the others except the mp itself. - # - put(vc_queue, mask) - put(vc_queue, monitor) - if not (mask := event( , , monitor.prog)) then - unschedule(monitor) # MP terminated - break next - } - if monitor.mask ~===:= mask then - union_mask() - } - } - else { - unschedule(monitor) # MP terminated - break - } - } - -end - -# Initialize the vc, load SP, load MPs. -# -procedure init() - local i, attribs, info - - Coordination := 1 # post vc's presence - - mpath := "/home/ralph/ibin/" - spath := "/home/ralph/SVP/SPs/" - - attribs := ui_atts() # vc's window attributes - push(attribs, "posx=10", "posy=10") # add initial positioning - - (WOpen ! attribs) | stop("*** can't open window for vc") - - vidgets := ui() # table of vidgets - - root := vidgets["root"] # root vidget - - delayval := 0 # start at fastest speed - VSetState(vidgets["speed"], delayval) - - pause := vidgets["pause"] - VSetState(pause, 1) # start paused to allow setup - - ticksum := 0 - - load_prg() | ExitNotice("Monitoring cancelled in specifying SP.") - - vc_handlers := table() # procedures for events vc handles - - vc_handlers[E_Tick] := vc_tick - vc_handlers[E_Error] := vc_error - - mps_names := [ - "program", - "roll", - "algae", - "napoleon", - "allocviews", - "tinylist", - "scater", - "locus" - ] - mps_selected := [ - On, # program - On, # roll - Off, # algae - Off, # napoleon - Off, # allocviews - Off, # tinylist - Off, # scater - Off # locus - ] - - add_mps() | ExitNotice("Monitoring cancelled in specifying MPs.") - - info := WOpen("lines=" || *mps + 5, "columns=32", "bg=white-gray", - "label=monitoring") - - WWrite(info, " SP: ", basename(program)) - WWrite(info) - WWrite(info, " MPs:") - every WWrite(info, " ", basename((!mps).name)) - - Raise() # bring control window to the front (may not make active) - - return - -end - -# Load SP. - -procedure load_prg() - static input, sps - - initial { - sps := [ - "chess", # chess playing - "concord", # concordance - "macho", # recursive descent parsing - "sortnews", # news sorting - "pool", # population growth - "singles", # bridge tournamen scheduling -# "beards", # parser constructor -# "yhcheng", # line editor - "rsg" # random sentence generation - ] - } - - repeat { - SelectDialog( "Select source program:", sps, sps[1]) == "Okay" | fail - - program := spath || dialog_value - SourceProgram := program || ".icn" - - # Note: Currently, the input data for the SP must be in the same - # directory as the SP, have the same base name as the SP, and - # have the suffix ".dat". - - &eventsource := load( - program, - , - open(spath || dialog_value || ".dat"), - open("/dev/null", "w"), - open("/dev/null", "w"), - BlkSize, - StrSize, - MstkSize - ) | { - Notice("Can't load " || dialog_value || ".") - next - } - - return - - } - -end - -# mp() - create and initialize a mp_rec. -# -procedure mp(name) - local rec - - rec := mp_rec(name) - rec.prog := load( - rec.name, - , - &input, - &output, - &errout, - BlkSize, - StrSize, - MstkSize - ) | ExitNotice("Can't load " || image(rec.name) || ".") - - variable("&eventsource", rec.prog) := ¤t | - ExitNotice("Internal inconsistency; no event source.") - - every variable("Monitored" | "EventSource", rec.prog) := &eventsource - - /rec.mask := '' - /rec.enabled := 1 - - return rec - -end - -# Handle pause toggle. - -procedure pause_cb(vidget, value) - - state := value - - return - -end - -# vc's main loop -# -procedure run() - local monitor, mask - - repeat { - delay(delayval) - - # Process interface events before going on to SP events. - - while (*Pending() > 0) | \state do - ProcessEvent(root, , shortcuts) - - # Process several SP events before going back to check for - # interface events. - - every 1 to EventIter do { - EvGet(unioncset) | Exit() # exit on termination of SP - - # Call vc's own handler for this event, if there is one. - - (\vc_handlers[&eventcode])() - - # Forward the event to those MPs that want it. - - every monitor := !EventCodeTable[&eventcode] do { - if mask := event( , , monitor.prog) then { - if mask ~=== monitor.mask then { - while type(mask) ~== "cset" do { - - # The MP (probably) has raised a signal; pass it on, then - # return to the mp to get his next event request. - - broadcast(mask, monitor) - if not (mask := event( , , monitor.prog)) then { - unschedule(monitor) # MP terminated - break next - } - } - if monitor.mask ~===:= mask then union_mask() - } - } - else unschedule(monitor) # MP terminated - } - } - } - -end - -# Exit when SP is done. - -procedure Exit() - - ExitNotice("Source program terminated normally.") - -end - -# Handle keyboard shortcuts. - -procedure shortcuts(e) - - if &meta then - case map(e) of { # fold case - "s": snap_view() - "q": exit() - "p": VSetState(pause, if \state then &null else 1) - } - - return - -end - -# Take snapshot of MP's visualization window. - -procedure snap_view() - local mp_names, rec, win - - mp_names := [] - - every rec := !mps do - put(mp_names, basename(rec.name)) - - if SelectDialog("Select MP visualization:", mp_names) == "Cancel" then fail - - dialog_value := mpath || dialog_value - - every rec := !mps do - if rec.name == dialog_value then { - win := \variable("Visualization", rec.prog) | - return FailNotice("No image available from " || rec.name) - snapshot( - win, - 0, - 0, - \WAttrib(win, "clipw" | "width"), - \WAttrib(win, "cliph" | "height") - ) | return FailNotice("Cannot produce image file.") - return - } - - return FailNotice("MP not found.") - -end - -# Control speed of event stream. - -procedure speed_cb(vidget, value) - - delayval := sqrt(value) - - return - -end - -# Determine the set of events required by the union of all MPs, including -# vc's and user input needs. -# -procedure union_mask() - local monitor, c - static tickset - - initial tickset := E_Tick ++ E_Error - - # EventCodeTable is keyed by events. For each event, the corresponding - # value is a list of MPs that need that event. - - EventCodeTable := table() - EventCodeTable[E_Tick] := [] - EventCodeTable[E_Error] := [] - - unioncset := tickset - - # Go through the list of MPs, and for each one that is currently - # enabled, add it to the list for each of its event codes. - - every monitor := !mps do { - if \monitor.enabled then { - unioncset ++:= monitor.mask - every c := !monitor.mask do { - /EventCodeTable[c] := [] - put(EventCodeTable[c], monitor) - } - } - } - - return - -end - -# Remove MP from list of MPs. -# -procedure unschedule(MP) - local newmps, monitor - - mps := lremvals(mps, MP) # remove MP - - union_mask() # recompute the union mask - - return - -end - -# Handle run-time error in SP. -# -procedure vc_error() - - # If error conversion is on in the SP, ignore the error. - # Otherwise, display the error information and then terminate - # monitoring. - - if keyword("error", &eventsource) = 0 then - ExitNotice( - "run-time error " || image(&eventvalue), - "", - "file " || keyword("file", &eventsource) || - ", line " || keyword("line", &eventsource), - "", - keyword("errortext", &eventsource), - "", - "offending value: " || image(keyword("errorvalue", &eventsource)) - ) - - else return - -end - -# Handle clock tick events in the SP. -# -procedure vc_tick() - - drawtime(ticksum +:= &eventvalue) - - return - -end - -#===<<vib:begin>>=== modify using vib; do not remove this marker line -procedure ui_atts() - return ["size=253,220", "bg=gray-white", "label=vc"] -end - -procedure ui(win, cbk) -return vsetup(win, cbk, - [":Sizer:::0,0,253,220:visualization coordinator",], - ["elapsed:Label:::10,156,91,13:elapsed time:",], - ["fast:Label:::209,103,28,13:fast",], - ["file:Menu:pull::1,2,36,21:File",file_cb, - ["snapshot @S","quit @Q"]], - ["label1:Label:::151,156,77,13:clock ticks",], - ["line1:Line:::0,25,252,25:",], - ["pause:Button:regular:1:10,54,50,20:pause",pause_cb], - ["slow:Label:::10,103,28,13:slow",], - ["speed:Slider:h:1:48,103,150,15:100,0,0",speed_cb], - ["odometer:Rect:invisible::103,153,41,20:",], - ) -end -#===<<vib:end>>=== end of section maintained by vib diff --git a/ipl/mprogs/vmsum.icn b/ipl/mprogs/vmsum.icn deleted file mode 100644 index 2124325..0000000 --- a/ipl/mprogs/vmsum.icn +++ /dev/null @@ -1,62 +0,0 @@ -############################################################################ -# -# File: vmsum.icn -# -# Subject: Program to tabulate virtual-machine operations -# -# Author: Ralph E. Griswold -# -# Date: November 22, 1997 -# -############################################################################ -# -# This file is in the public domain. -# -############################################################################ -# -# This tool tabulates event codes. -# -############################################################################ -# -# Requires: Version 9 graphics and MT Icon -# -############################################################################ -# -# Links: evinit, numbers, opnames -# -############################################################################ -# -# Includes: evdefs.icn -# -############################################################################ - -$include "evdefs.icn" - -link evinit -link numbers -link opnames - -procedure main(args) - local name, summary, total, i - - EvInit(get(args) | &null) # initialize interface - - name := opnames() - - summary := table(0) - total := 0 - - while EvGet(E_Opcode) do { - summary[&eventvalue] +:= 1 - total +:= 1 - } - - summary := sort(summary,4) - total /:= 100.0 - - write(left("code",10), right("count",8), right("percent",10)) - write() - while write(left(name[get(summary)],10), right(i := get(summary),8), - " ", fix(i, total, 5, 2)) - -end diff --git a/ipl/packs/README b/ipl/packs/README index 9dc760d..f067e91 100644 --- a/ipl/packs/README +++ b/ipl/packs/README @@ -1,7 +1,11 @@ +Contributed packages distributed with Icon: + euler Euler compiler and interpreter + icondb loadable C function for access to SQL database ibpag2 LR-based parser generator idol Idol; object-oriented Icon written in Icon itweak interactive debugger loadfunc C functions loaded dynamically + loadfuncpp interface for loading C++ functions skeem Scheme language, implemented in Icon tcll1 parser-generator and parser diff --git a/ipl/packs/ibpag2/Makefile b/ipl/packs/ibpag2/Makefile index 56d917e..d9c7d18 100644 --- a/ipl/packs/ibpag2/Makefile +++ b/ipl/packs/ibpag2/Makefile @@ -23,7 +23,7 @@ LIBDIR = /usr/local/lib/icon/data # # Name of your icon compiler and compiler flags. # -ICONC = icont +ICONT = icont IFLAGS = -u -s #-Sc 400 -Sg 400 -Si 2000 -Sn 4000 -SF 40 SHAR = /usr/local/bin/shar @@ -48,7 +48,7 @@ SHARFILES = $(SRC) $(PARSER) $(GLRPARSER) sample.ibp beta2ref.ibp \ all: $(PROGNAME) $(PROGNAME): $(SRC) - $(ICONC) $(IFLAGS) -o $(PROGNAME) $(SRC) + $(ICONT) $(IFLAGS) -o $(PROGNAME) $(SRC) ########################################################################## diff --git a/ipl/packs/ibpag2/README b/ipl/packs/ibpag2/README index c2f5d82..0accddd 100644 --- a/ipl/packs/ibpag2/README +++ b/ipl/packs/ibpag2/README @@ -997,10 +997,7 @@ do. Please be sure to read the directions in the makefile carefully, and set DESTDIR and LIBDIR to the directory where you want the executable and parser file to reside. Also, make sure the paths -you specify are correct for your Icon executables. Although Ibpag2 -will apparently compile using iconc, I would recommend using the -interpreter, icont, first, unless you are planning on working with a -large grammar. +you specify are correct for your Icon executables. If you are using some other system - one that lacks "make" - then shame on your manufacturer :-). You'll be a bit inconvenienced. @@ -1012,13 +1009,7 @@ Try typing: version.icn slshupto.icn The backslashes merely indicate that the next line is a continuation. -The whole thing should, in other words, be on a single line. As noted -above, you may compile rather than interpret - if your OS supports the -Icon compiler. Just replace "icont" above with "iconc." The -resulting executable will run considerably faster than with "icont," -although the time required to compile it may be large, and the (still -somewhat experimental) compiler may not work smoothly in all -environments. +The whole thing should, in other words, be on a single line. If your operating system support environment variables, and you have set up your LPATH according to the specifications in the Icon @@ -1050,7 +1041,7 @@ input and output redirection. Naturally, the above example assumes that Ibpag2 is in c:\ibpag2. Ibpag2 assumes the existence on your system, not only of an -Icon interpreter or compiler, but also of an up-to-date Icon Program +Icon interpreter, but also of an up-to-date Icon Program Library. There are several routines included in the IPL that Bibleref uses. Make sure you (or the local system administrators) have put the IPL online, and have translated the appropriate object modules. Set diff --git a/ipl/packs/icondb/Makefile b/ipl/packs/icondb/Makefile new file mode 100644 index 0000000..5e616c4 --- /dev/null +++ b/ipl/packs/icondb/Makefile @@ -0,0 +1,41 @@ +# icondb -- Icon database interface contributed by Carl Sturtivant. + +# Requires GNU make, gcc, mysql utilities, and mysql development package. + +ifndef TARGET + +ifneq ($(strip $(shell g++ -v 2>&1 | grep "darwin")),) +TARGET=mac +else +ifneq ($(strip $(shell g++ -v 2>&1 | grep "cygwin")),) +TARGET=cygwin +else +TARGET=other +endif +endif + +endif #TARGET + + +ICON_PATH=../../.. + + +SHARED_mac = -bundle -undefined suppress +SHARED_cygwin = -shared +SHARED_other = -shared + +PIC_mac = -flat_namespace +PIC_other = -fPIC + +EXTRA_cygwin = $(ICON_PATH)/bin/iload.a -Wl,--enable-auto-import +EXTRA_other = -I./ + + +default: + icont -ucs icondb.icn + cp icondb.u1 icondb.u2 $(ICON_PATH)/lib + sh -c "gcc -I../../cfuncs $(SHARED_$(TARGET)) -o mysqldb.so $(PIC_$(TARGET)) `mysql_config --cflags` mysqldb.c `mysql_config --libs`" + cp mysqldb.so $(ICON_PATH)/bin + +clean Clean: + rm -f *.u? *.o *.so */*.o */*.u? */*.so diff --git a/ipl/packs/icondb/cgi.icn b/ipl/packs/icondb/cgi.icn new file mode 100644 index 0000000..2b47f9d --- /dev/null +++ b/ipl/packs/icondb/cgi.icn @@ -0,0 +1,43 @@ + +#everything needed for typical web form handling + +procedure cgiparms() #returns a table, mapping names to lists of values + local GET_data, POST_data, data, i, pname, pvalue, s + static result + initial { + result := table() + GET_data := trim(getenv("QUERY_STRING"))|"" + if *GET_data = 0 then GET_data := &null + POST_data := reads(&input, getenv("CONTENT_LENGTH")) + if \GET_data & \POST_data then + data := GET_data || "&" || POST_data + else + data := \GET_data | \POST_data + if /data then return result + data ? every i := upto('&')|0 do { + tab(i) ? { + pname := _urldecode( tab(upto('=')) ) + move(1) + pvalue := _urldecode( tab(0) ) + /result[pname] := [] + put( result[pname], pvalue ) + } + if pos(0) then break + move(1) + } + } + return result +end + +procedure _urldecode(url) + local s + s := "" + url ? repeat { + s ||:= tab(upto('%+')|0) + if pos(0) then return s + case move(1) of { + "%" : s ||:= char("16r" || map(move(2)) ) + "+" : s ||:= " " + } + } +end diff --git a/ipl/packs/icondb/icondb.icn b/ipl/packs/icondb/icondb.icn new file mode 100644 index 0000000..5cbc67b --- /dev/null +++ b/ipl/packs/icondb/icondb.icn @@ -0,0 +1,105 @@ + +#simulation of the real icondb.icn +#using the C mysql and postgresql interfaces for Icon 9.4. +#use with cgi.icn (instead of web.icn) +#until loadfuncpp becomes reliable + +#WARNING: can only connect to one mysql and one postgresql database at a time + +#CS 2008/7/27 + + +link io + +#the C interface +procedure _mysqldb(arg[]) + return ( _mysqldb := pathload("mysqldb.so","mysqldb") )!arg +end + +procedure _postgresqldb(arg[]) + return ( _postgresqldb := pathload("postgresqldb.so","postgresqldb") )!arg +end + +#simulated external value +record database_handle(connection, c_interface) + +#simulated mysql connection procedure +procedure _connectmysql(dbname, user, pwd, host, port) + local connection, result + icondb_error := &null + connection := [dbname, user, pwd] + if put(connection, \host) then put(connection, \port) + result := _mysqldb(connection) + if /result then return database_handle(connection, _mysqldb) + icondb_error := result + fail +end + +#simulated postgresql connection procedure +procedure _connectpostgresql(dbname, user, pwd, host, port) + local connection, result + icondb_error := &null + connection := [dbname, user, pwd] + if put(connection, \host) then put(connection, \port) + result := _postgresqldb(connection) + if /result then return database_handle(connection, _postgresqldb) + icondb_error := result + fail +end + +global icondb_error + +#icondb returns a connection procedure for a known kind of dbms +#which may then be called following the pattern +#dbhandle := connect(dbname, user, pwd, host, port) +#where host and port are optional + +procedure icondb(kind) + case kind of { + "mysql" : return _connectmysql + "postgresql" : return _connectpostgresql + default : stop("icondb: unknown dbms\nerror: ", image(kind)) | fail + } +end + +procedure dbclose(db) + if type(db) ~== "database_handle" then + stop("dbclose: not a database handle: ", image(db)) + icondb_error := &null + db.c_interface() + return +end + +procedure dbquery(db, query, constructor) + local result, rec + if type(db) ~== "database_handle" then + stop("dbquery: not a database handle: ", image(db)) + case type(constructor) of { + "null" : + &null + "procedure" : + image(constructor) ? { + ="record constructor" | + stop("dbquery: not a record constructor: ", image(constructor)) + } + default : + stop("dbquery: not a record constructor: ", image(constructor)) + } + icondb_error := &null + result := db.c_interface(query) + case type(result) of { + "integer" | "null" : return result + "list" : case type(result[1]) of { + "list": + if /constructor then + suspend !result + else { + if result[1] & *constructor() ~= *result[1] then + stop("dbquery: ",image(constructor)," needs at least ",*rec[1]," fields." ) + suspend constructor!!result + } + "integer" : icondb_error := result + } + } +end + diff --git a/ipl/packs/icondb/mysqldb.c b/ipl/packs/icondb/mysqldb.c new file mode 100644 index 0000000..06dc179 --- /dev/null +++ b/ipl/packs/icondb/mysqldb.c @@ -0,0 +1,289 @@ + +/*-----------------3/27/2007 11:23AM----------------- + * loadable C function mysqldb for icon access to + * a mySQL database from linux, by Carl Sturtivant. + * (This also built on solaris.) + * + * This should be Garbage Collection safe except + * under very extreme memory shortages. + * + * Requires a mySQL installation to build. + * I used the following from bash: + +CFG=/usr/bin/mysql_config +sh -c "gcc -shared -o mysqldb.so -fPIC `$CFG --cflags` mysqldb.c `$CFG --libs`" + + * for details about calling mysqldb, see below. + * --------------------------------------------------*/ + +#include <stdio.h> +#include <string.h> + +/* http://dev.mysql.com/doc/refman/5.0/en/c.html */ +/* #include "/usr/include/mysql/mysql.h" */ +#include <mysql.h> + + +#include "icall.h" + + +/* macros obtained by modifying some from icall.h */ + +#define Mkinteger(i, dp) \ +do { (dp)->dword = D_Integer; (dp)->vword = (i); } while(0) + +#define Mkstring(s, dp) \ +do { word n = strlen(s); \ +(dp)->dword = n; (dp)->vword = (word)alcstr(s,n); } while(0) + +/* ensure that return to icon removes our tended descriptors from the list */ +#define ReturnDescriptor(d) do { gcu_aware_pop(); return ( argv[0] = (d), 0 ); } while(0) +#define ReturnError(d, n) do { gcu_aware_pop(); return ( argv[0] = (d), n ); } while(0) + + +/****************start of Garbage Collection Utilities****************/ + +/* Structure for chaining descriptors to be tended properly by GC (rstructs.h) */ +struct tend_desc { + struct tend_desc *previous; + int num; + descriptor d[1]; /* actual size is in num */ +}; +typedef struct tend_desc gcu_tended; + +/* global chain of such structures used by iconx (rinit.r) */ +extern gcu_tended *tend; + +/* int parameter to pass to gcu_initialize */ +#define gcu_max(vars) ( (sizeof(vars) - sizeof(gcu_tended) )/sizeof(descriptor) ) + +/* initialize all descriptors to &null and assign the number */ +static void gcu_initialize(int maxindex, void *descriptors) { + int i; + gcu_tended *desc = (gcu_tended *)descriptors; + desc->num = maxindex+1; + for( i = 0; i <= maxindex; ++i ) (desc->d)[i] = nulldesc; +} + +/* add descriptors in a gcu_tended structure to the tended list */ +static void gcu_aware_push(void *descriptors) { + gcu_tended *desc = (gcu_tended *)descriptors; + desc->previous = tend; + tend = descriptors; +} + +/* remove descriptors in a gcu_tended structure from the tended list */ +static void gcu_aware_pop() { + tend = tend->previous; +} + +/****************end of Garbage Collection utilities****************/ + + +/****************start of list utilities****************/ + +int Zlist(descriptor argv[]); /* resolved in iconx: icon function list(i,X):L */ +int Osubsc(descriptor argv[]); /* resolved in iconx: icon operator L[i]:v */ +int Oasgn(descriptor argv[]); /* resolved in iconx: icon operator v:=X */ + +typedef int (*iconfunction)(descriptor argv[]); + +/* safely call an icon built-in function or operator with two arguments from C. */ +static descriptor iconcall2(iconfunction F, descriptor x1, descriptor x2) { + struct { /* structure like struct tend_desc with extra descriptors at the bottom */ + gcu_tended other; /* vital: used to chain onto the tend list */ + descriptor stack[3]; /* GC is aware of these once this struct is pushed onto the tend list */ + } tended; + gcu_initialize( gcu_max(tended), &tended ); /* vital: call before icon may be made aware of this */ + gcu_aware_push( &tended ); /* GC is now aware of tended.stack */ + tended.stack[0] = nulldesc; + tended.stack[1] = x1; + tended.stack[2] = x2; + F(tended.stack); /* No error handling for the uses below */ + gcu_aware_pop(); /* vital: GC is now unaware of tended.stack */ + return tended.stack[0]; +} + +/* returns list(n, &null) --- allocates memory */ +static descriptor newlist(int length) { + descriptor len; + Mkinteger(length, &len); + return iconcall2( &Zlist, len, nulldesc ); +} + +/* returns list[index] := value */ +static descriptor assign(descriptor list, int index, descriptor value) { + descriptor i; + Mkinteger(index, &i); + return iconcall2( &Oasgn, iconcall2(&Osubsc, list, i), value ); +} + +/* returns .list[index] */ +static descriptor subscript(descriptor list, int index) { + descriptor i, result; + Mkinteger(index, &i); + result = iconcall2(&Osubsc, list, i); + /* result of an icon subscripting operation is a variable */ + deref(&result, &result); /* deref resolved in iconx */ + return result; +} + +/****************end of list utilities****************/ + + +/* make icon list of mysql error information */ +static descriptor error_info(int mysqlNumber, const char * mysqlError) { + descriptor number; + struct { + gcu_tended other; + descriptor text, ls; + } tended; + gcu_initialize( gcu_max(tended), &tended ); + gcu_aware_push( &tended ); + tended.ls = newlist(2); + Mkinteger(mysqlNumber, &number); + Mkstring((char *)mysqlError, &tended.text); + assign( tended.ls, 1, number ); + assign( tended.ls, 2, tended.text ); + gcu_aware_pop(); + return tended.ls; +} + +/* make mySQL row retrieved from query results into icon list */ +static descriptor convertrow(MYSQL_ROW row, int numfields) { + int i; + struct { + gcu_tended other; + descriptor x, ls; + } tended; + gcu_initialize( gcu_max(tended), &tended ); + gcu_aware_push( &tended ); + tended.ls = newlist(numfields); + for( i = 1; i <= numfields; ++i ) { + if( row[i-1] ) Mkstring( row[i-1], &tended.x ); + else tended.x = nulldesc; + assign( tended.ls, i, tended.x ); + } + gcu_aware_pop(); + return tended.ls; +} + +/*-------------------------------------------------- + * Called with a list, mysqldb attempts to connect. + * Only one database can be connected to at a time. + * Needs the database name, username, password, + * and optionally the host, and if so optionally + * the port number, all passed in a list. The host + * defaults to localhost, and the port number to + * the default port number for mySQL. + * + * Called with a string, mysqldb attempts to + * execute that string as a mySQL query. + * + * Called with no parameters, mysqldb closes + * the connection if it is open. + * + * Returns a list of lists for a SELECT query, or + * the number of rows affected for other queries. + * Otherwise, fails if everything works, returns + * error information if not, except if incorrect + * argument types are supplied, in which case the + * result is an error. + * --------------------------------------------------*/ +int mysqldb(int argc, descriptor argv[]) { + static MYSQL dbh; /* connection sticks around between calls */ + static int connected = 0; + + MYSQL_RES *result; + MYSQL_ROW row; + char *querystring, *hoststring, + *databasestring, *userstring, *passwordstring; + int i, len, rowsize, portnum; + struct { + gcu_tended other; + descriptor ls, host, port, database, user, password, answer; + } tended; + gcu_initialize( gcu_max(tended), &tended ); + gcu_aware_push( &tended ); + + + if( argc == 0 ) { /* close connection */ + if( connected ) mysql_close(&dbh); + connected = 0; + gcu_aware_pop(); + Fail; + } /* end close connection */ + + if( argc >= 1 && IconType(argv[1]) == 'L' ) { /* connect to MySQL */ + if( connected ) + ReturnDescriptor( error_info(-1, "mysqldb: already connected") ); + if( !mysql_init(&dbh) ) + ReturnDescriptor( error_info(-1, "mysqldb: cannot initialize mySQL!") ); + + tended.ls = argv[1]; + hoststring = "localhost"; /* host defaults to localhost */ + portnum = 0; /* port defaults to 0 giving the mySQL default */ + + switch( ListLen(tended.ls) ) { + default: + ReturnDescriptor( error_info(-1, "mysqldb: list of dbname, user, pwd, [host, [port]] expected") ); + case 5 : + tended.port = subscript(tended.ls, 5); + if( !cnv_int(&tended.port,&tended.port) ) ReturnError(tended.port,101); + portnum = IntegerVal(tended.port); + case 4 : + tended.host = subscript(tended.ls, 4); + if ( !cnv_str(&tended.host,&tended.host) ) ReturnError(tended.host,103); + hoststring = StringVal(tended.host); + case 3 : + tended.password = subscript(tended.ls, 3); + if ( !cnv_str(&tended.password,&tended.password) ) ReturnError(tended.password,103); + passwordstring = StringVal(tended.password); + tended.user = subscript(tended.ls, 2); + if ( !cnv_str(&tended.user,&tended.user) ) ReturnError(tended.user,103); + userstring = StringVal(tended.user); + tended.database = subscript(tended.ls, 1); + if ( !cnv_str(&tended.database,&tended.database) ) ReturnError(tended.database,103); + databasestring = StringVal(tended.database); + } + + if( mysql_real_connect(&dbh, hoststring, userstring, + passwordstring, databasestring, portnum, NULL, 0) ) { + connected = 1; + gcu_aware_pop(); + Fail; + } + else ReturnDescriptor( error_info(mysql_errno(&dbh), mysql_error(&dbh)) ); + } /* end connect to MySQL */ + + if( argc >= 1 && IconType(argv[1]) == 's' ) { /* execute a query */ + if( !connected ) + ReturnDescriptor( error_info(-1, "mysqldb: not connected") ); + querystring = StringVal(argv[1]); + + if( mysql_query(&dbh, querystring) ) + ReturnDescriptor( error_info(mysql_errno(&dbh), mysql_error(&dbh)) ); + + result = mysql_store_result(&dbh); + + if( !result ) /* not a SELECT query or some sort of error */ + if( mysql_field_count(&dbh) != 0 ) + ReturnDescriptor( error_info(mysql_errno(&dbh), mysql_error(&dbh)) ); + else { /* not a SELECT query */ + gcu_aware_pop(); + RetInteger( mysql_affected_rows(&dbh) ); + } + + /* SELECT query */ + tended.answer = newlist( mysql_num_rows(result) ); + rowsize = mysql_num_fields(result); + i = 0; + while( row = mysql_fetch_row(result) ) + assign( tended.answer, ++i, convertrow(row, rowsize) ); + mysql_free_result(result); + ReturnDescriptor(tended.answer); + } /* end execute a query */ + + /* wrong argument type to mysqldb */ + ReturnError(argv[1], 110); /* list or string expected */ +} diff --git a/ipl/packs/loadfunc/Makefile b/ipl/packs/loadfunc/Makefile index 66c72d7..6c9cc2f 100644 --- a/ipl/packs/loadfunc/Makefile +++ b/ipl/packs/loadfunc/Makefile @@ -3,7 +3,7 @@ # It is assumed that the standard C functions will be found by iconx. include ../../../Makedefs -CFLAGS = -O $(CFDYN) -I../../cfuncs +CFLAGS = -O $(CFDYN) -I../../cfuncs ICONT = icont IFLAGS = -us @@ -28,7 +28,8 @@ libnames.icn: Makefile echo '$$define FUNCLIB "./$(FUNCLIB)"' >libnames.icn $(FUNCLIB): $(FUNCS) - CC="$(CC)" CFLAGS="$(CFLAGS)" sh $(MKLIB) $(FUNCLIB) $(FUNCS) + CC="$(CC)" CFLAGS="$(CFLAGS)" BIN="../../../bin" \ + sh $(MKLIB) $(FUNCLIB) $(FUNCS) # Copy progs to ../../iexe: diff --git a/ipl/packs/loadfuncpp/Makefile b/ipl/packs/loadfuncpp/Makefile new file mode 100644 index 0000000..15cce8b --- /dev/null +++ b/ipl/packs/loadfuncpp/Makefile @@ -0,0 +1,107 @@ +# loadfuncpp -- a C++ interface for icon. See doc/index.htm. + +# Requires GNU make and g++. + +CC=g++ + +ifneq ($(strip $(shell g++ -v 2>&1 | grep "darwin")),) +TARGET=mac +else +ifneq ($(strip $(shell g++ -v 2>&1 | grep "cygwin")),) +TARGET=cygwin +else +ifneq ($(strip $(shell g++ -v 2>&1 | grep "solaris")),) +#TARGET=sun +#CC=cc +TARGET=other +else +TARGET=other +endif +endif +endif + + + +#ICON_PATH = $(shell cd $(PWD)/../../..; pwd) +ICON_PATH = ../../.. + +ICON_BUILD_PATH = $(ICON_PATH) + +ICON_BIN_PATH = $(ICON_PATH)/bin +ICON_LIB_PATH = $(ICON_PATH)/lib +ICON_HDR_PATH = $(ICON_BUILD_PATH)/src/h + +ICON_HDR_FILE = \"$(ICON_HDR_PATH)/rt.h\" + +FLAGS_cygwin = -Wl,--enable-auto-import +FLAGS_cygwin_default = $(ICON_BIN_PATH)/iconx.a +FLAGS_cygwin_iexample = $(ICON_BIN_PATH)/iload.a + +SHARED_mac = -bundle -undefined suppress +SHARED_cygwin = -shared +SHARED_other = -shared + +IMPLIB_cygwin = -Wl,--out-implib=iload.a +PIC_other = -fPIC +PIC_mac = -flat_namespace + +COPY_cygwin =cp iload.a $(ICON_BIN_PATH)/ + +COPY_PACKAGE_cygwin=cp iload.a package/bin + +DEPS_cygwin_default = $(ICON_BIN_PATH)/iconx.a +DEPS_cygwin_iexample = $(ICON_BIN_PATH)/iload.a + +DEPS_default = $(ICON_BIN_PATH)/iload.so $(ICON_BIN_PATH)/iloadgpx.so $(ICON_BIN_PATH)/iloadnogpx.so +SLIBS = iload.so iloadgpx.so iloadnogpx.so + +.PHONY : default clean iconsrc iexample package + + +default : $(DEPS_default) $(DEPS_$(TARGET)_default) $(ICON_LIB_PATH)/loadfuncpp.u1 + +iload.so : %.so : %.cpp loadfuncpp.h iload.h + $(CC) $(PIC_$(TARGET)) $(SHARED_$(TARGET)) -o $@ $< $(FLAGS_$(TARGET)_default) $(FLAGS_$(TARGET)) $(IMPLIB_$(TARGET)) -DRTT=$(ICON_HDR_FILE) + +iloadgpx.so iloadnogpx.so : %.so : %.cpp loadfuncpp.h iload.h $(DEPS_$(TARGET)_iexample) + $(CC) $(PIC_$(TARGET)) $(SHARED_$(TARGET)) -o $@ $< $(FLAGS_$(TARGET)_default) $(FLAGS_$(TARGET)_iexample) $(FLAGS_$(TARGET)) -DRTT=$(ICON_HDR_FILE) + +$(DEPS_default) : $(ICON_BIN_PATH)/%.so : %.so + cp $< $(ICON_BIN_PATH) + +$(ICON_BIN_PATH)/iload.a : iload.a + cp $< $(ICON_BIN_PATH) + +iload.a : iload.so + +$(ICON_LIB_PATH)/loadfuncpp.u1 : loadfuncpp.u1 + cp loadfuncpp.u? $(ICON_LIB_PATH) + +loadfuncpp.u1 : loadfuncpp.icn + icont -cs loadfuncpp.icn + +clean Clean: + rm -f iexample *.exe *.u? *.so *.o *% *~ core .#* + +iconsrc: $(ICON_BIN_PATH) $(ICON_LIB_PATH) $(ICON_HDR_PATH) + @ echo "install Icon 9.5+ from source in $(ICON_PATH)" + @ exit 1 + +iexample: iexample.so $(DEPS_$(TARGET)_iexample) + icont -s iexample.icn + +iexample.so : iexample.cpp loadfuncpp.h + $(CC) $(PIC_$(TARGET)) $(SHARED_$(TARGET)) -o $@ $< $(FLAGS_$(TARGET)_iexample) $(FLAGS_$(TARGET)) + +package : $(SLIBS) loadfuncpp.u1 + mkdir package + mkdir package/bin + cp iload*.so package/bin + $(COPY_PACKAGE_$(TARGET)) + mkdir package/lib + cp loadfuncpp.u? package/lib + mkdir package/h + cp loadfuncpp.h package/h + tar -cf $(TARGET).tar package + gzip $(TARGET).tar + rm -rf package/ diff --git a/ipl/packs/loadfuncpp/doc/Makefile b/ipl/packs/loadfuncpp/doc/Makefile new file mode 100644 index 0000000..586d7d6 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/Makefile @@ -0,0 +1,51 @@ + +#Automatically generated from Makefile.mak and examples.txt by ../savex.icn + +# icont -ucs file.icn -> u1, u2, goes in the /opt/icon/lib/. +# g++ stuff -> .os, goes in the /opt/icon/bin/. + + +ifndef TARGET + +ifneq ($(strip $(shell g++ -v 2>&1 | grep "darwin")),) +TARGET=mac +else +ifneq ($(strip $(shell g++ -v 2>&1 | grep "cygwin")),) +TARGET=cygwin +else +TARGET=other +endif +endif + +endif + +FLAGS_cygwin = /opt/icon/bin/iload.a -Wl,--enable-auto-import +FLAGS_other = + +SHARED_mac = -bundle -undefined suppress +SHARED_cygwin = -shared +SHARED_other = -shared + +PIC_other = -fPIC +PIC_mac = -flat_namespace + +EXAMPLES = bang.exe divide.exe divide2.exe dull.exe generator.exe isexternal.exe iterate.exe keyword.exe makelist.exe object.exe +DYNAMICS = bang.so divide.so divide2.so dull.so generator.so isexternal.so iterate.so keyword.so makelist.so object.so + +%.so : %.cpp loadfuncpp.h + g++ $(SHARED_$(TARGET)) $(PIC_$(TARGET)) -o $@ $< $(FLAGS_$(TARGET)) + +%.exe : %.icn %.so + icont -so $@ $* + +default: $(DYNAMICS) $(EXAMPLES) + +.PHONY : loadfuncpp.h + +loadfuncpp.h : ../loadfuncpp.h + cp ../loadfuncpp.h ./ + +test : clean default + +clean : + rm -f *.exe *.so *.o *% *~ core .#* diff --git a/ipl/packs/loadfuncpp/doc/Makefile.mak b/ipl/packs/loadfuncpp/doc/Makefile.mak new file mode 100644 index 0000000..7a10f86 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/Makefile.mak @@ -0,0 +1,34 @@ + +ifndef TARGET +ifneq ($(strip $(shell g++ -v 2>&1 | grep "cygwin")),) +TARGET=cygwin +else +TARGET=other +endif +endif + +FLAGS_cygwin = /opt/icon/bin/iload.a -Wl,--enable-auto-import +FLAGS_other = + +PIC_other = -fPIC + +EXAMPLES = #exe# +DYNAMICS = #so# + +%.so : %.cpp loadfuncpp.h + g++ -shared $(PIC_$(TARGET)) -o $@ $< $(FLAGS_$(TARGET)) + +%.exe : %.icn %.so + icont -so $@ $* + +default: $(DYNAMICS) $(EXAMPLES) + +.PHONY : loadfuncpp.h + +loadfuncpp.h : ../loadfuncpp.h + cp ../loadfuncpp.h ./ + +test : clean default + +clean : + rm -f *.exe *.so *.o *% *~ core .#* diff --git a/ipl/packs/loadfuncpp/doc/bang.cpp b/ipl/packs/loadfuncpp/doc/bang.cpp new file mode 100644 index 0000000..c300169 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/bang.cpp @@ -0,0 +1,35 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + + + + +struct addup: public iterate { + safe total; + int count; + + addup(): total(0L), count(0) {} + + virtual void takeNext(const value& x) { + total = total + x; + } + virtual bool wantNext(const value& x) { + return ++count <= 10; + } +}; + +extern "C" int sumlist(value argv[]) { + addup sum; + sum.bang(argv[1]); + argv[0] = sum.total; + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/doc/bang.icn b/ipl/packs/loadfuncpp/doc/bang.icn new file mode 100644 index 0000000..bf0aba9 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/bang.icn @@ -0,0 +1,10 @@ + +link loadfuncpp + + +procedure main() + sumlist := loadfuncpp("./bang.so", "sumlist", 1) + write( sumlist([1,2,3,4,5]) ) +end + + diff --git a/ipl/packs/loadfuncpp/doc/compile.htm b/ipl/packs/loadfuncpp/doc/compile.htm new file mode 100644 index 0000000..04a8514 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/compile.htm @@ -0,0 +1,57 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN"> +<HTML> + +<HEAD> + <META HTTP-EQUIV="Content-Type" CONTENT="text/html;CHARSET=iso-8859-1"> + <TITLE>loadfuncpp</TITLE> + <LINK REL="stylesheet" TYPE="text/css" HREF="loadfuncpp.css"> +</HEAD> + +<BODY> + +<H3></H3> +<CENTER> +<P> +<TABLE BORDER="0" WIDTH="700"> + <TR> + <TD WIDTH="100%"> + <H1 ALIGN="CENTER"><BR> + Loadfuncpp</H1> + <H2 ALIGN="CENTER">Compiler Options</H2> + <H3 ALIGN="CENTER">Carl Sturtivant, January 2009</H3> + <BLOCKQUOTE> + <BLOCKQUOTE> + <P>When compiling a shared object (or dll) to dynamically load functions into Icon via loadfuncpp, try the following + compilation options, which have been successfully used to build libraries with version 0.91alpha on the systems + below. <BR> + <BR> + Everything is simplest if all shared objects are placed in the icon/bin directory and all linkable Icon (.u1/.u2 + files) are placed in the icon/lib directory. + </BLOCKQUOTE> + <H2>Linux</H2> + <P><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">g++ -fPIC -shared -o </FONT><I><FONT SIZE="2" FACE="Courier New, Courier">file</FONT></I><FONT + SIZE="2" COLOR="black" FACE="Courier New, Courier">.so </FONT><I><FONT SIZE="2" FACE="Courier New, Courier">file</FONT></I><FONT + SIZE="2" COLOR="black" FACE="Courier New, Courier">.cpp</FONT></P> + <H2>Cygwin</H2> + <P><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">g++ -shared -o </FONT><I><FONT SIZE="2" FACE="Courier New, Courier">file</FONT></I><FONT + SIZE="2" COLOR="black" FACE="Courier New, Courier">.so </FONT><I><FONT SIZE="2" FACE="Courier New, Courier">file</FONT></I><FONT + SIZE="2" COLOR="black" FACE="Courier New, Courier">.cpp </FONT><I><FONT SIZE="2" FACE="Courier New, Courier">iload_so_directory</FONT></I><FONT + SIZE="2" COLOR="black" FACE="Courier New, Courier">/iload.a</FONT></P> + <H2>Macintosh</H2> + <P><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">g++ -flat_namespace -bundle -undefined suppress -o + </FONT><I><FONT SIZE="2" FACE="Courier New, Courier">file</FONT></I><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">.so + </FONT><I><FONT SIZE="2" FACE="Courier New, Courier">file</FONT></I><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">.cpp</FONT> + <H2>Solaris</H2> + <P><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">g++ -fPIC -shared -o </FONT><I><FONT SIZE="2" FACE="Courier New, Courier">file</FONT></I><FONT + SIZE="2" COLOR="black" FACE="Courier New, Courier">.so </FONT><I><FONT SIZE="2" FACE="Courier New, Courier">file</FONT></I><FONT + SIZE="2" COLOR="black" FACE="Courier New, Courier">.cpp</FONT> + </BLOCKQUOTE> + </TD> + </TR> +</TABLE> + +</CENTER> + +</BODY> + +</HTML> diff --git a/ipl/packs/loadfuncpp/doc/divide.cpp b/ipl/packs/loadfuncpp/doc/divide.cpp new file mode 100644 index 0000000..a9f3d99 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/divide.cpp @@ -0,0 +1,20 @@ + + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int div(value argv[]) { + safe x(argv[1]), y(argv[2]), z; + z = ( x/y, x%y ); + argv[0] = z; + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/doc/divide.icn b/ipl/packs/loadfuncpp/doc/divide.icn new file mode 100644 index 0000000..9e5c0b8 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/divide.icn @@ -0,0 +1,10 @@ + +link loadfuncpp + +procedure main() + div := loadfuncpp("./divide.so", "div", 2) + ls := div(79, 10) + every write(!ls) +end + + diff --git a/ipl/packs/loadfuncpp/doc/divide2.cpp b/ipl/packs/loadfuncpp/doc/divide2.cpp new file mode 100644 index 0000000..a9f3d99 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/divide2.cpp @@ -0,0 +1,20 @@ + + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int div(value argv[]) { + safe x(argv[1]), y(argv[2]), z; + z = ( x/y, x%y ); + argv[0] = z; + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/doc/divide2.icn b/ipl/packs/loadfuncpp/doc/divide2.icn new file mode 100644 index 0000000..48da848 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/divide2.icn @@ -0,0 +1,10 @@ + +link loadfuncpp + +procedure main() + div := loadfuncpp("./divide2.so", "div", 2) + ls := div(79, 10) + every write(!ls) +end + + diff --git a/ipl/packs/loadfuncpp/doc/dull.cpp b/ipl/packs/loadfuncpp/doc/dull.cpp new file mode 100644 index 0000000..f1683ee --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/dull.cpp @@ -0,0 +1,15 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int dull(value argv[]) { + argv[0] = nullvalue; + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/doc/dull.icn b/ipl/packs/loadfuncpp/doc/dull.icn new file mode 100644 index 0000000..128f8a1 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/dull.icn @@ -0,0 +1,9 @@ + +link loadfuncpp + + +procedure main() + dull := loadfuncpp("./dull.so", "dull", 1) + write(image( dull() )) +end + diff --git a/ipl/packs/loadfuncpp/doc/examples.txt b/ipl/packs/loadfuncpp/doc/examples.txt new file mode 100644 index 0000000..3b6a98e --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/examples.txt @@ -0,0 +1,10 @@ +bang +divide +divide2 +dull +generator +isexternal +iterate +keyword +makelist +object diff --git a/ipl/packs/loadfuncpp/doc/generator.cpp b/ipl/packs/loadfuncpp/doc/generator.cpp new file mode 100644 index 0000000..5f99158 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/generator.cpp @@ -0,0 +1,31 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +class sequence: public generator { + safe current, inc; + public: + sequence(safe start, safe increment) { + current = start - increment; + inc = increment; + } + virtual bool hasNext() { + return true; + } + virtual value giveNext() { + return current = current + inc; + } +}; + +extern "C" int seq2(value argv[]){ + sequence seq(argv[1], argv[2]); + return seq.generate(argv); +} + + diff --git a/ipl/packs/loadfuncpp/doc/generator.icn b/ipl/packs/loadfuncpp/doc/generator.icn new file mode 100644 index 0000000..cf46dff --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/generator.icn @@ -0,0 +1,9 @@ + +link loadfuncpp + + +procedure main() + seq2 := loadfuncpp("./generator.so", "seq2", 1) + every write( seq2(1001, 99) \ 30 ) +end + diff --git a/ipl/packs/loadfuncpp/doc/hello.php b/ipl/packs/loadfuncpp/doc/hello.php new file mode 100644 index 0000000..d96e074 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/hello.php @@ -0,0 +1,10 @@ +<HTML> + <HEAD> + <TITLE>Hello World</TITLE> + </HEAD> + <BODY> +<? + print("Hello World"); +?> + </BODY> +</HTML> diff --git a/ipl/packs/loadfuncpp/doc/icall.txt b/ipl/packs/loadfuncpp/doc/icall.txt new file mode 100644 index 0000000..700929f --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/icall.txt @@ -0,0 +1,140 @@ + +A Technique to Call Icon from C under Icon Version 9 + Carl Sturtivant, 2008/2/20 Confidential Draft #1 + + +1. Summary. + +A new Icon function written in C with a special interface may be +dynamically loaded from a shared object using the built-in function +loadfunc [GT95]. We show how such a function may in turn call an Icon +procedure using the technique described below, provided that the +procedure call itself does not suspend, but only returns or fails. Note +that this does not impose constraints of any kind upon other procedures +executed as a consequence of calling the original procedure. In +particular, the Icon procedure called from C may in turn lead to a call +of another Icon function written in C calling Icon recursively. The +technique described has been implemented and briefly tested with Icon +9.51(?). + + +2. Overview. + +If the body of an Icon function written in C is to call an Icon +procedure that does not suspend and retrieve its return value, all +without modifying iconx, then there are a number of hurdles to jump. +The procedure descriptor, and those of its arguments must be pushed +onto the Icon stack, and the interpreter induced to believe it needs to +execute an icode instruction to invoke it, one that is not present in +the icode it loaded. Once the procedure returns (or fails) the +interpreter must be induced to return control to C just after the point +where the attempt to call it occurred, rather than simply to go on to +the next icode instruction. Then the result of the call needs to be +popped off the Icon stack so that it is in the same state as before the +call, since C does not normally modify the Icon stack. (Other details +of the state of the interpreter will be restored by the mechanism +whereby a procedure is called in Icon.) In all other respects, the main +interpreter loop must continue to behave as before. + +These hurdles are insurmountable, so long as the code of the main +interpreter loop is inviolate. The code of that loop as it is +incorporated into iconx is inviolate, since a design goal is that the +technique should work with the existing implementation. Therefore, we +take a copy of that loop, and modify it to the ends above, and execute +it only in order to call Icon. (The original interpreter continues to +be used for all other purposes.) Dynamic linking allows the new +interpreter loop to refer to all C globals and functions in iconx, and +so nothing else need be copied, these things are merely referred to. In +fact it takes very little modification of the copy to achieve these +goals, and the result is a C function called icall to which the +procedure and its arguments are passed to effect the call to Icoan. To +simplify this interface, the arguments are passed as a single Icon +list. The resulting function then has similar semantics as the binary +"!" operator in Icon, (which we henceforth call 'apply' as it applies a +procedure to its argument list) except that it may be called from C. + + +3. Implementation. + +The main interpreter loop written in RTL resides in the file +src/runtime/interp.r in the Icon distribution. This was translated into +the corresponding C file xinterp.c by the RTL translator rtt with the +command 'rtt -x interp.r'. Now this C file is edited into a file +compiled into a single C function called icall, taking two descriptors +(a procedure and a list of arguments) and returning an integer code. +The effect of calling icall is to apply the procedure to its arguments, +and restore the state of the interpreter, leaving the result of the +call just beyond the stack pointer for retrieval. + +The contents of xinterp.c consist of some global variables and a +function interp containing the interpreter loop. The global variable +declarations are all modified by prefixing them with 'extern', so that +they now simply refer to those used by the interpreter loop inside +iconx. The function interp that returns an integer signal and has two +parameters: an integer fsig used when the interpreter is called +recursively to simulate suspension, and cargp, a pointer into the Icon +stack. The function interp is renamed icall. + +Examination of src/runtime/init.r indicates that the signal 0 is passed +to interp when it is initially called non-recursively to start up +iconx. So fsig is removed from the parameter list and made a local +variable initialized to 0. Similarly cargp is made a local variable, +and icall is given two parameters theProc and arglist used to pass that +necessary for the call to Icon. Immediately after the initial +declarations inside icall, the Icon stack pointer sp is used to +initialize cargp to refer to the first descriptor on the stack beyond +sp, which is assigned the procedure desciptor parameter of icall. The +desciptor beyond that is assigned the argument list descriptor +parameter, and the stack pointer augmented to refer to its last word. A +new local variable result_sp is initialized to location on the stack of +the last word of the procedure descriptor. This is used by the +mechanism to return to C described below. Now the details of pushing +the procedure descriptor and the argument list descriptor onto the +stack are complete. + +The body of interp consists of some straight-line code followed by the +interpreter loop, which contains some code to get the next icode +instruction followed by a switch to jump to the correct code to execute +it, all inside and endless loop. Just before the loop starts, an +unconditional goto is inserted, jumping to a newly inserted label +called aptly 'apply' which is placed just after the switch label +(called Op_Apply in interp.r) which precedes the code to implement the +icode 'apply' instruction, that implements the apply operator (binary +"!") in Icon. This instruction expects to find a procedure descriptor +and a list descriptor on the stack, and then causes the icode +instructions of the procedure to be accordingly invoked. Now the +details of calling the procedure are complete. What is left to insert +is the mechanism to return to C. + +When the procedure that we called returns or fails, it will execute a +'pret' instruction or a 'pfail' instruction. However, these +instructions may also be executed by Icon procedures called from the +one we called. At the end of the code for 'pret' inside the switch in +the interpreter is a 'break' to leave the switch and go round to get +the next icode instruction. Just before that 'break' we can tell if our +procedure call is the one returning by comparing the Icon stack pointer +sp to the one we saved, result_sp, which our procedure call will have +restored sp to when it overwrote the procedure descriptor with the +result of the call. So if they are equal, we can clean up (decrement +ilevel, move sp just before the former procedure descriptor) and +return, finishing the call to icall. Now C can retrieve the result of +the call just beyond the stack pointer. The 'pfail' code is similar, +just before a jump to efail, which we do not execute since the context +of our call is not an Icon expression. C can determine success or +failure from the integer code returned. This completes the mechanism to +return to C. + + +4. Conclusions + +Overall this mechanism depends upon few things, mainly upon the fact +that when a procedure is called, the Icon stack below the part used for +the call is not modified during the call. Our copy of the interpreter +loop is identical to the original with the exception of the code added +for the C return mechanism, which is only exceptionally executed. And +the Icon procedure call mechanism itself will save and restore the +interpreter state apart from the stack pointer which we abuse at the +start and restore at the end. The compiled result with gcc was about 10 +Kbyte. A simple test confirmed that call and return occur in the +correct order, from Icon to C to Icon returning to C returning to Icon. + diff --git a/ipl/packs/loadfuncpp/doc/index.htm b/ipl/packs/loadfuncpp/doc/index.htm new file mode 100644 index 0000000..dad9df8 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/index.htm @@ -0,0 +1,87 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN"> +<HTML> + +<HEAD> + <META HTTP-EQUIV="Content-Type" CONTENT="text/html;CHARSET=iso-8859-1"> + <TITLE>loadfuncpp</TITLE> + <LINK REL="stylesheet" TYPE="text/css" HREF="loadfuncpp.css"> +</HEAD> + +<BODY> + +<CENTER> +<P> +<TABLE BORDER="0" WIDTH="700"> + <TR> + <TD WIDTH="100%"> + <H1 ALIGN="CENTER"><BR> + Loadfuncpp</H1> + <H2 ALIGN="CENTER">A Dynamic Library used to aid Adding <BR> + External Functions written in C++ to<BR> + <A HREF="http://www.cs.arizona.edu/icon/lb3.htm" target="_blank">The Icon Programming Language</A></H2> + <H3 ALIGN="CENTER">Carl Sturtivant, February 2010, <FONT COLOR="#FF9900">version 0.91alpha</FONT></H3> + <BLOCKQUOTE> + <H5><FONT COLOR="#FF9900"></FONT></H5> + <H3><FONT COLOR="#CC0000">Features</FONT></H3> + </BLOCKQUOTE> + <UL> + <LI><FONT COLOR="#FF9900">Works with the existing Icon runtime system with no modification</FONT> + <LI><FONT COLOR="#FF9900">Call Icon with call syntax from C++ and vice-versa, recursively</FONT> + <LI><FONT COLOR="#FF9900">Has a simple way to create new Icon datatypes by inheritance</FONT> + <LI><FONT COLOR="#FF9900">Write new Icon functions in C++ that suspend a sequence of results</FONT> + <LI><FONT COLOR="#FF9900">Iterate in C++ through result sequences generated by Icon</FONT> + <LI><FONT COLOR="#FF9900">All Icon functions, keywords and operators made available in C++</FONT> + <LI><FONT COLOR="#FF9900">Takes care of garbage collection safety automatically</FONT> + <H5></H5> + </UL> + <BLOCKQUOTE> + <BLOCKQUOTE> + <BLOCKQUOTE> + <BLOCKQUOTE> + <BLOCKQUOTE> + <H4><A HREF="manual.htm">documentation</A><BR> + <A HREF="loadfuncpp.htm">experimental binaries</A><BR> + <A HREF="compile.htm">compilation options</A></H4> + </BLOCKQUOTE> + </BLOCKQUOTE> + </BLOCKQUOTE> + </BLOCKQUOTE> + <H3>News</H3> + <BLOCKQUOTE> + <P>2010/2/10 (I am releasing this now having moved on to a new implementation of the language entirely.) There + are no known bugs, but bugs almost certainly exist. This pack needs systematic in-depth testing for subtle issues + connected to garbage collection. Specifically, the mechanism to call Icon from C++ pushes onto the top of the Icon + stack a region used by a copy of the interpreter loop that's used to execute the Icon procedure called from C++. + I have not investigated how the Icon stack is garbage collected, and this region does not extend the stack the + way that Icon does. If this proves unsafe for garbage collection, the stack region for such a call may have to + have suitable frames containing pointers to the lower part of the stack (or vice-versa) placed in it to repair + this deficiency. Also, the way garbage collection safety of Icon values in C++ variables is ensured is to use the + constructor to implicitly link them onto the far end of the main co-expression's safe list, and unlink them from + there using the destructor. This is almost certainly safe from the usual call and return mechanism in iconx for + protecting local variables, but needs testing and verification.<BR> + <BR> + 2009/1/20 fixed a bug where a call of any C++ external function that in turn calls Icon and afterIcon returns calls + Icon::runerr would not correctly report the name and arguments of said function in the resulting traceback. Upped + the version number to 0.91alpha.<BR> + <BR> + 2009/1/20 loadfuncpp now searches for a shared object on the path defined by the environment variable FPATH with + the icon/bin directory appended if you specify no path. FPATH undefined leads loadfuncpp to search the current + directory followed by the icon/bin directory.<BR> + <BR> + 2009/1/12 <FONT COLOR="#FF9900">loadfuncpp has been completely overhauled</FONT>, and the old version is now obsolete. + Many small functions have been added to eliminate ambiguities in programs that use loadfuncpp, and the central + class has been renamed and a class eliminated. Small pieces of missing functionality have been added. The documentation + has been modified accordingly. It is now close to it's final form, and in need of some serious beta testing, and + I have someone who has agreed to do that. Once this is done, loadfuncpp will be made available as a pack with the + Icon 9.5 source distribution. + </BLOCKQUOTE> + </BLOCKQUOTE> + </TD> + </TR> +</TABLE> + +</CENTER> + +</BODY> + +</HTML> diff --git a/ipl/packs/loadfuncpp/doc/isexternal.cpp b/ipl/packs/loadfuncpp/doc/isexternal.cpp new file mode 100644 index 0000000..ef5d219 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/isexternal.cpp @@ -0,0 +1,31 @@ + + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + + +#include "loadfuncpp.h" +using namespace Icon; + +class myval: public external { + public: + virtual value name() { return "my external"; } +}; + +extern "C" int myext(value argv[]) { + argv[0] = new myval(); + return SUCCEEDED; +} + +extern "C" int ismine(value argv[]) { + if( argv[1].isExternal("my external") ) + argv[0] = "Yes!"; + else + argv[0] = "No!"; + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/doc/isexternal.icn b/ipl/packs/loadfuncpp/doc/isexternal.icn new file mode 100644 index 0000000..bfa509a --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/isexternal.icn @@ -0,0 +1,14 @@ + +link loadfuncpp + +procedure main() + myext := loadfuncpp("./isexternal.so", "myext", 0) + ismine := loadfuncpp("./isexternal.so", "ismine", 1) + x := myext() + write(image(x)) + write(image(type(x))) + write("is mine? ", ismine(x)) + write("is also mine? ", ismine(3)) +end + + diff --git a/ipl/packs/loadfuncpp/doc/iterate.cpp b/ipl/packs/loadfuncpp/doc/iterate.cpp new file mode 100644 index 0000000..9a57e59 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/iterate.cpp @@ -0,0 +1,34 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + + +struct addup: public iterate { + safe total; + int count; + + addup(): total(0L), count(0) {} + + virtual void takeNext(const value& x) { + total = total + x; + } + virtual bool wantNext(const value& x) { + return ++count <= 10; + } +}; + + +extern "C" int sum10(value argv[]){ + addup sum; + sum.every(argv[1], argv[2]); + argv[0] = sum.total; + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/doc/iterate.icn b/ipl/packs/loadfuncpp/doc/iterate.icn new file mode 100644 index 0000000..1fd1cb7 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/iterate.icn @@ -0,0 +1,13 @@ + +link loadfuncpp + + +procedure main() + sum10 := loadfuncpp("./iterate.so", "sum10", 2) + write( sum10(f,[]) ) +end + +procedure f() + suspend 1 to 15 +end + diff --git a/ipl/packs/loadfuncpp/doc/keyword.cpp b/ipl/packs/loadfuncpp/doc/keyword.cpp new file mode 100644 index 0000000..3e3bde8 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/keyword.cpp @@ -0,0 +1,16 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int assignprog(value argv[]) { + safe newname(argv[1]); + &progname = newname; + return FAILED; +} + diff --git a/ipl/packs/loadfuncpp/doc/keyword.icn b/ipl/packs/loadfuncpp/doc/keyword.icn new file mode 100644 index 0000000..0340f9c --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/keyword.icn @@ -0,0 +1,10 @@ + +link loadfuncpp + + +procedure main() + assignprog := loadfuncpp("./keyword.so", "assignprog", 1) + assignprog("Silly") + write(&progname) +end + diff --git a/ipl/packs/loadfuncpp/doc/loadfuncpp.css b/ipl/packs/loadfuncpp/doc/loadfuncpp.css new file mode 100644 index 0000000..975cbcb --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/loadfuncpp.css @@ -0,0 +1,41 @@ +body { background-color: #FFFFFF; + color: #0066CC; + font-family: Georgia, "Times New Roman", serif; +} +h1 { background-color: #CCFFFF; + color: #0099FF; + line-height: 200%; + font-family: Georgia, "Times New Roman", serif; +} +h2 { background-color: #CCFFFF; + color: #0099FF; + font-family: Georgia, "Times New Roman", serif; + line-height: 100% +} +h3 { background-color: #CCFFFF; + font-family: Georgia, "Times New Roman", serif; + line-height: 90% +} +h4 { background-color: #FFFFFF; + color: #FF9900; + font-family: Georgia, "Times New Roman", serif; + line-height: 100% +} +a {color: #333300; +} +p {font-size: 120%; +} +ul {font-weight: bold; +} +#wrapper { width: 850px; + margin-left: auto; + margin-right: auto; +} +.nav { font-weight: bold; + font-size: 1.25em; +} +#footer {font-size: .75em; + font-style: italic; +} + + diff --git a/ipl/packs/loadfuncpp/doc/loadfuncpp.h b/ipl/packs/loadfuncpp/doc/loadfuncpp.h new file mode 100644 index 0000000..934bca9 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/loadfuncpp.h @@ -0,0 +1,470 @@ + +/* C++ support for easy extensions to icon via loadfunc, + * without garbage collection difficulties. + * Include this and link to iload.cpp which + * contains the necessary glue. + * See iexample.cpp for typical use. + * Carl Sturtivant, 2008/3/17 + */ + +#include<new> +#include <cstdio> + +enum kind { Null, Integer, BigInteger, Real, Cset, File, Procedure, Record, List, + Set=10, Table=12, String, Constructor, Coexpression=18, External, Variable }; + +enum special_value { NullString, StringLiteral, NewString, NullChar, Illegal }; + +enum { + SUCCEEDED = 7, // Icon function call returned: A_Continue + FAILED = 1 // Icon function call failed: A_Resume +}; + +class value; //Icon value (descriptor) +class safe; //for garbage-collection-safe Icon valued C++ variables and parameters of all kinds +class keyword; //Icon keyword represented as an object with unary & +class variadic; //for garbage-collection-safe variadic function argument lists +class proc_block; //block specifying a procedure to iconx +class external_block; //block specifying an external value to iconx +class external_ftable; //function pointers specifying external value behavior to iconx +class external; //C++ Object specifying an external value + +typedef int iconfunc(value argv[]); //type of icon built in functions or operators with a fixed number of arguments +typedef int iconfvbl(int argc, value argv[]); //type of icon built in functions with a variable number of arguments + +extern const value nullvalue; //for default arguments +extern const value nullstring; +extern const value nullchar; +extern const value illegal; //for unwanted trailing arguments +extern void syserror(const char*); //fatal termination Icon-style with error message +#define Fs_Read 0001 /* file open for reading */ +#define Fs_Write 0002 /* file open for writing */ +extern value IconFile(int fd, int status, char* fname); //make an Icon file descriptor + +namespace Icon { +//all keywords excepting &fail, &cset (avoiding a name collision with function cset) +extern keyword allocated; +extern keyword ascii; +extern keyword clock; +extern keyword collections; +extern keyword current; +extern keyword date; +extern keyword dateline; +extern keyword digits; +extern keyword dump; +extern keyword e; +extern keyword error; +extern keyword errornumber; +extern keyword errortext; +extern keyword errorvalue; +extern keyword errout; +extern keyword features; +extern keyword file; +extern keyword host; +extern keyword input; +extern keyword lcase; +extern keyword letters; +extern keyword level; +extern keyword line; +extern keyword main; +extern keyword null; +extern keyword output; +extern keyword phi; +extern keyword pi; +extern keyword pos; +extern keyword progname; +extern keyword random; +extern keyword regions; +extern keyword source; +extern keyword storage; +extern keyword subject; +extern keyword time; +extern keyword trace; +extern keyword ucase; +extern keyword version; +}; //namespace Icon + +static void initialize_keywords(); + +class keyword { //objects representing Icon keywords + friend void initialize_keywords(); + iconfunc* f; + public: + safe operator&(); //get the keyword's value (could be an Icon 'variable') +}; + + +class value { //a descriptor with class +//data members modelled after 'typedef struct { word dword, vword; } descriptor;' from icall.h + private: + long dword; + long vword; + public: + friend class safe; + friend value IconFile(FILE* fd, int status, char* fname); + value(); //&null + value(special_value, const char* text = ""); + value(int argc, value* argv); //makes a list of parameters passed in from Icon + value(int); + value(long); + value(float); + value(double); + value(char*); + value(const char*); + value(proc_block&); + value(proc_block*); + value(external*); + operator int(); + operator long(); + operator float(); + operator double(); + operator char*(); + operator external*(); + operator proc_block*() const; + bool operator==(const value&) const; + value& dereference(); + value intify(); + bool isNull(); + bool notNull(); + bool isExternal(const value&); + value size() const; + kind type(); + bool toString(); //attempted conversion in place + bool toCset(); + bool toInteger(); + bool toReal(); + bool toNumeric(); + value subscript(const value&) const; //produces an Icon 'variable' + value& assign(const value&); //dereferences Icon style + value put(value x = nullvalue); + value push(value x = nullvalue); + void dump() const; + void printimage() const; + int compare(const value&) const; //comparator-style result: used for Icon sorting + value negative() const; // -x + value complement() const; // ~x + value refreshed() const; // ^x + value random() const; // ?x + value plus(const value&) const; + value minus(const value&) const; + value multiply(const value&) const; + value divide(const value&) const; + value remainder(const value&) const; + value power(const value&) const; + value union_(const value&) const; // x ++ y + value intersection(const value&) const; // x ** y + value difference(const value&) const; // x -- y + value concatenate(const value&) const; // x || y + value listconcatenate(const value&) const;// x ||| y + value slice(const value&, const value&) const; // x[y:z] + value& swap(value&); // x :=: y + value activate(const value& y = nullvalue) const; // y @ x ('*this' is activated) + value apply(const value&) const; // x!y (must return, not fail or suspend) +}; //class value + + +class generator { +//class to inherit from for defining loadable functions that are generators + public: + int generate(value argv[]); //call to suspend everything produced by next() + protected: //override these, and write a constructor + virtual bool hasNext(); + virtual value giveNext(); +}; //class generator + + +class iterate { +//class to inherit from for iterating over f!arg or !x + public: + void every(const value& g, const value& arg); //perform the iteration over g!arg + void bang(const value& x); //perform the iteration over !x + //override these, write a constructor and the means of recovering the answer + virtual bool wantNext(const value& x); + virtual void takeNext(const value& x); +}; + + + +class safe_variable { +//data members modelled after 'struct tend_desc' from rstructs.h + friend class value; + friend inline int safecall_0(iconfunc*, value&); + friend inline int safecall_1(iconfunc*, value&, const value&); + friend inline int safecall_2(iconfunc*, value&, const value&, const value&); + friend inline int safecall_3(iconfunc*, value&, const value&, const value&, const value&); + friend inline int safecall_4(iconfunc*, value&, const value&, const value&, const value&, const value&); + friend inline int safecall_5(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&); + friend inline int safecall_6(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&, const value&); + friend inline int safecall_v0(iconfvbl*, value&); + friend inline int safecall_v1(iconfvbl*, value&, const value&); + friend inline int safecall_v2(iconfvbl*, value&, const value&, const value&); + friend inline int safecall_v3(iconfvbl*, value&, const value&, const value&, const value&); + friend inline int safecall_vbl(iconfvbl*,safe&, const variadic&); + protected: + safe_variable *previous; + int num; + value val; + safe_variable(); + safe_variable(int); + safe_variable(long); + safe_variable(double); + safe_variable(value); + safe_variable(proc_block&); + safe_variable(proc_block*); + safe_variable(int, value*); + inline void push(safe_variable*& tendlist, int numvalues=1); + inline void pop(safe_variable*& tendlist); +}; //class safe_variable + + +class variadic: public safe_variable { + public: + variadic(int); + variadic(long); + variadic(float); + variadic(double); + variadic(char*); + variadic(value); + variadic(const safe&); + variadic(const safe&, const safe&); + variadic& operator,(const safe&); + operator value(); + ~variadic(); +}; //class variadic + + +class external_block { +//modelled on 'struct b_external' in icon/src/h/rstructs.h + friend class external; + friend class value; + static long extra_bytes; //silent extra parameter to new + long title; + long blksize; + long id; + external_ftable* funcs; + external* val; + static void* operator new(size_t); //allocated by iconx + static void operator delete(void*); //do nothing + external_block(); +}; + +class external { + friend class value; + static external_block* blockptr; //silent extra result of new + protected: + long id; + public: + static void* operator new(size_t); //allocated by new external_block() + static void operator delete(void*); //do nothing + external(); + virtual ~external() {} //root class + virtual long compare(external*); + virtual value name(); + virtual external* copy(); + virtual value image(); +}; + + +class safe: public safe_variable { +//use for a garbage collection safe icon valued safe C++ variable + friend class variadic; + friend class global; + public: + safe(); //&null + safe(const safe&); + safe(int); + safe(long); + safe(float); + safe(double); + safe(char*); + safe(const value&); + safe(const variadic&); + safe(proc_block&); + safe(proc_block*); + safe(int, value*); //from parameters sent in from Icon + ~safe(); + safe& operator=(const safe&); + //augmenting assignments here + safe& operator+=(const safe&); + safe& operator-=(const safe&); + safe& operator*=(const safe&); + safe& operator/=(const safe&); + safe& operator%=(const safe&); + safe& operator^=(const safe&); + safe& operator&=(const safe&); + safe& operator|=(const safe&); + // ++ and -- here + safe& operator++(); + safe& operator--(); + safe operator++(int); + safe operator--(int); + //conversion to value + operator value() const; + //procedure call + safe operator()(); + safe operator()(const safe&); + safe operator()(const safe& x1, const safe& x2, + const safe& x3 = illegal, const safe& x4 = illegal, + const safe& x5 = illegal, const safe& x6 = illegal, + const safe& x7 = illegal, const safe& x8 = illegal); + safe operator[](const safe&); + + friend safe operator*(const safe&); //size + friend safe operator-(const safe&); + friend safe operator~(const safe&); //set complement + friend safe operator+(const safe&, const safe&); + friend safe operator-(const safe&, const safe&); + friend safe operator*(const safe&, const safe&); + friend safe operator/(const safe&, const safe&); + friend safe operator%(const safe&, const safe&); + friend safe operator^(const safe&, const safe&); //exponentiation + friend safe operator|(const safe&, const safe&); //union + friend safe operator&(const safe&, const safe&); //intersection + friend safe operator&&(const safe&, const safe&); //set or cset difference + friend safe operator||(const safe&, const safe&); //string concatenation + friend bool operator<(const safe&, const safe&); + friend bool operator>(const safe&, const safe&); + friend bool operator<=(const safe&, const safe&); + friend bool operator>=(const safe&, const safe&); + friend bool operator==(const safe&, const safe&); + friend bool operator!=(const safe&, const safe&); + friend variadic operator,(const safe&, const safe&); //variadic argument list construction + + safe slice(const safe&, const safe&); // x[y:z] + safe apply(const safe&); // x ! y + safe listcat(const safe&); // x ||| y + safe& swap(safe&); // x :=: y + safe create(); // create !x + safe create(const safe&); // create x!y + safe activate(const safe& y = nullvalue); // y@x + safe refresh(); // ^x + safe random(); // ?x + safe dereference(); // .x + bool isIllegal() const; //is an illegal value used for trailing arguments +}; //class safe + + +//Icon built-in functions +namespace Icon { + safe abs(const safe&); + safe acos(const safe&); + safe args(const safe&); + safe asin(const safe&); + safe atan(const safe&, const safe&); + safe center(const safe&, const safe&, const safe&); + safe char_(const safe&); + safe chdir(const safe&); + safe close(const safe&); + safe collect(); + safe copy(const safe&); + safe cos(const safe&); + safe cset(const safe&); + safe delay(const safe&); + safe delete_(const safe&, const safe&); + safe detab(const variadic&); + safe detab( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe display(const safe&, const safe&); + safe dtor(const safe&); + safe entab(const variadic&); + safe entab( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe errorclear(); + safe exit(const safe&); + safe exp(const safe&); + safe flush(const safe&); + safe function(); //generative: returns a list + safe get(const safe&); + safe getch(); + safe getche(); + safe getenv(const safe&); + safe iand(const safe&, const safe&); + safe icom(const safe&); + safe image(const safe&); + safe insert(const safe&, const safe&, const safe&); + safe integer(const safe&); + safe ior(const safe&, const safe&); + safe ishift(const safe&, const safe&); + safe ixor(const safe&, const safe&); + safe kbhit(); + safe left(const safe&, const safe&, const safe&); + safe list(const safe&, const safe&); + safe loadfunc(const safe&, const safe&); + safe log(const safe&); + safe map(const safe&, const safe&, const safe&); + safe member(const safe&, const safe&); + safe name(const safe&); + safe numeric(const safe&); + safe open(const safe&, const safe&); + safe ord(const safe&); + safe pop(const safe&); + safe proc(const safe&, const safe&); + safe pull(const safe&); + safe push(const variadic&); + safe push( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe put(const variadic&); + safe put( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe read(const safe&); + safe reads(const safe&, const safe&); + safe real(const safe&); + safe remove(const safe&); + safe rename(const safe&, const safe&); + safe repl(const safe&, const safe&); + safe reverse(const safe&); + safe right(const safe&, const safe&, const safe&); + safe rtod(const safe&); + safe runerr(const safe&, const safe&); + safe runerr(const safe&); + safe seek(const safe&, const safe&); + safe serial(const safe&); + safe set(const safe&); + safe sin(const safe&); + safe sort(const safe&, const safe&); + safe sortf(const safe&, const safe&); + safe sqrt(const safe&); + safe stop(); + safe stop(const variadic&); + safe stop( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe string(const safe&); + safe system(const safe&); + safe table(const safe&); + safe tan(const safe&); + safe trim(const safe&, const safe&); + safe type(const safe&); + safe variable(const safe&); + safe where(const safe&); + safe write(); + safe write(const variadic&); + safe write( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe writes(const variadic&); + safe writes( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + //generative functions follow, crippled to return a single value + safe any(const safe&, const safe&, const safe&, const safe&); + safe many(const safe&, const safe&, const safe&, const safe&); + safe upto(const safe&, const safe&, const safe&, const safe&); + safe find(const safe&, const safe&, const safe&, const safe&); + safe match(const safe&, const safe&, const safe&, const safe&); + safe bal(const safe&, const safe&, const safe&, const safe&, const safe&, const safe&); + safe move(const safe&); + safe tab(const safe&); +}; //namespace Icon + diff --git a/ipl/packs/loadfuncpp/doc/loadfuncpp.htm b/ipl/packs/loadfuncpp/doc/loadfuncpp.htm new file mode 100644 index 0000000..50fc4b8 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/loadfuncpp.htm @@ -0,0 +1,42 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN"> +<HTML> + +<HEAD> + <META HTTP-EQUIV="Content-Type" CONTENT="text/html;CHARSET=iso-8859-1"> + <TITLE>loadfuncpp</TITLE> + <LINK REL="stylesheet" TYPE="text/css" HREF="loadfuncpp.css"> +</HEAD> + +<BODY> + +<H3></H3> +<CENTER> +<P> +<TABLE BORDER="0" WIDTH="700"> + <TR> + <TD WIDTH="100%"> + <H1 ALIGN="CENTER"><BR> + Loadfuncpp</H1> + <H2 ALIGN="CENTER">Experimental Binary Distribution</H2> + <H3 ALIGN="CENTER">Carl Sturtivant, February 2010</H3> + <BLOCKQUOTE> + <BLOCKQUOTE> + <P>All versions are in the public domain as of now.<BR> + <BR> + <FONT COLOR="#FF9900">All versions are provisional, experimental and hacked off at speed</FONT>; sane behavior + is no more than probable so <B><FONT COLOR="#CC0000">use at your own risk</FONT></B><FONT COLOR="#CC0000">.</FONT></P> + + <P>Read the <A HREF="manual.htm#Installation" target="_blank">documentation</A> for information on installation + and use. Everything is simplest if all shared objects are placed in the icon/bin directory and all linkable Icon + (.u1/.u2 files) are placed in the icon/lib directory. + </BLOCKQUOTE> + </BLOCKQUOTE> + </TD> + </TR> +</TABLE> + +</CENTER> + +</BODY> + +</HTML> diff --git a/ipl/packs/loadfuncpp/doc/makelist.cpp b/ipl/packs/loadfuncpp/doc/makelist.cpp new file mode 100644 index 0000000..90b8c5d --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/makelist.cpp @@ -0,0 +1,16 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int makelist(int argc, value argv[]) { + safe arglist(argc, argv); + argv[0] = arglist; + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/doc/makelist.icn b/ipl/packs/loadfuncpp/doc/makelist.icn new file mode 100644 index 0000000..e5e4cd8 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/makelist.icn @@ -0,0 +1,10 @@ + +link loadfuncpp + + +procedure main() + makelist := loadfuncpp("./makelist.so", "makelist") + write(image( ls := makelist(1,2,3) )) + every write(!ls) +end + diff --git a/ipl/packs/loadfuncpp/doc/manual.htm b/ipl/packs/loadfuncpp/doc/manual.htm new file mode 100644 index 0000000..38046e1 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/manual.htm @@ -0,0 +1,1558 @@ +<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2//EN"> +<HTML> + +<HEAD> + <META HTTP-EQUIV="Content-Type" CONTENT="text/html;CHARSET=iso-8859-1"> + <TITLE>loadfuncpp</TITLE> + <LINK REL="stylesheet" TYPE="text/css" HREF="loadfuncpp.css"> +</HEAD> + +<BODY> + +<CENTER> +<P> +<TABLE BORDER="0" WIDTH="700"> + <TR> + <TD WIDTH="100%"> + <H1 ALIGN="CENTER"><BR> + Loadfuncpp</H1> + <H2 ALIGN="CENTER">How to Write External Functions and Libraries<BR> + for <A HREF="http://www.cs.arizona.edu/icon/lb3.htm" target="_blank">The Icon Programming Language</A> in C++</H2> + <H3 ALIGN="CENTER">Carl Sturtivant, February 2010, <FONT COLOR="#FF9900">version 0.91alpha</FONT></H3> + <BLOCKQUOTE> + <H2><A NAME="Contents"></A>Contents</H2> + <UL> + <LI><A HREF="#Contents">Contents</A> + <LI><A HREF="#Summary">Summary</A> + <LI><A HREF="#Installation">Installation</A> + <UL> + <LI><A HREF="#CorrectIconInstallation">Correct Icon Installation</A> + <LI><A HREF="#DefaultPlacement">Default Placement of Loadfuncpp Files</A> + <LI><A HREF="#AlternativePlacement">Alternative Placement of Loadfuncpp Files</A> + <LI><A HREF="#LoadfuncppInstallationTest">Loadfuncpp Installation Test</A> + </UL> + <LI><A HREF="#Manual">Manual</A> + <UL> + <LI><A HREF="#Writing">Writing, Loading and Calling an External Function</A> + <LI><A HREF="#Working">Working with Icon Values</A> + <UL> + <LI><A HREF="#Initialization">Assignment & Initialization</A> + <LI><A HREF="#Operations">Icon Operations</A> + <LI><A HREF="#Functions">Icon Built-in Functions</A> + <LI><A HREF="#Keywords">Icon Keywords</A> + <LI><A HREF="#Types">Types, Conversions and Errors</A> + </UL> + <LI><A HREF="#Variadic">Variadic Functions and Dynamic List Construction</A> + <LI><A HREF="#Calling">Calling Icon from C++</A> + <LI><A HREF="#Generators">Working with Generators</A> + <UL> + <LI><A HREF="#Generate">Writing External Functions that are Generators</A> + <LI><A HREF="#Iterate">Calling Icon Procedures that are Generators in C++</A> + <LI><A HREF="#Bang">Iterating over Exploded Structures in C++</A> + <LI><A HREF="#Coexpressions">Working with Coexpressions in C++</A> + </UL> + <LI><A HREF="#Externals">Working with External Values</A> + <LI><A HREF="#Records">Using Icon Records as Objects</A> + </UL> + </UL> + <H2><A NAME="Summary"></A>Summary</H2> + <P>Since 1996 a new function for Version 9 of <A HREF="http://www.cs.arizona.edu/icon/" target="_blank">Icon</A> + could be written in C following a certain <A HREF="http://www.cs.arizona.edu/icon/current/cfuncs.htm" target="_blank">interface</A>, + and compiled into a shared library, where such is a <A HREF="http://www.ibm.com/developerworks/library/l-shobj/" + target="_blank">shared object</A> (.so) under Unix-like operating systems. More recently this has been implemented + using dynamically linked libraries (DLLs) under <A HREF="http://www.cs.arizona.edu/icon/v950/relnotes.htm" + target="_blank">cygwin</A>. The library could then be dynamically loaded by an Icon program calling the built-in + function <A HREF="http://www.cs.arizona.edu/icon/current/cfuncs.htm" target="_blank">loadfunc</A> which is passed + the location and name of the library and the name of the C function desired, and which returns an Icon function + that can subsequently be called. A suite of useful <A HREF="http://www.cs.arizona.edu/icon/library/fcfuncs.htm" + target="_blank">examples</A> of this technique is a part of the distribution of Icon.</P> + <P>Writing a significantly complex external function for use by <A HREF="http://www.cs.arizona.edu/icon/current/cfuncs.htm" + target="_blank">loadfunc</A> is potentially difficult for two reasons. First, an Icon structure (or other value, + string, list, set, table, et cetera) referred to solely by variables inside external code could be garbage collected + by Icon. Second, working directly with Icon data more complex than numbers, strings and files requires a thorough + understanding of the <A HREF="http://www.cs.arizona.edu/icon/ftp/doc/ib1up.pdf" target="_blank">implementation + of Icon</A>. The Icon runtime system is implemented in an <A HREF="http://www.cs.arizona.edu/icon/ftp/doc/ipd261.pdf" + target="_blank">extension of C</A> that is automatically translated into C. The design of the Icon virtual machine + is not object oriented, and contains a great deal of straight-line code. Icon structures are operated upon as combinations + of complex linked blocks. Writing code to work directly with such is lengthy, error prone and time consuming.</P> + <P>Loadfuncpp is a tool that makes writing external functions for Icon a relatively simple matter, requiring very + little understanding of the implementation of the Icon virtual machine. Loadfuncpp exploits the close compatibility + of C and C++ to provide a clean abstract interface to Icon. External functions for Icon are declared with C linkage, + and the Icon virtual machine requires no modification to use external functions written using loadfuncpp.</P> + <P>Beginning C++ programmers with programming experience in other languages should have little difficulty with + using loadfuncpp. It is not necessary to use templates, exceptions, or RTTI to use loadfuncpp. Little beyond some + C experience plus how to define a simple class with virtual and non-virtual member functions is needed to use loadfuncpp. + So C programmers with OOP experience but without C++ experience will also find loadfuncpp not difficult to use.</P> + <P>Loadfuncpp makes extensive use of operator overloading and other techniques to provide in C++ essentially the + same suite of operations, functions and capabilities that are available to the Icon programmer in Icon. The use + of these facilities in C++ is at most an order of magnitude more difficult than the corresponding Icon, and is + often much easier than that. These facilities include the ability to write external functions that suspend a sequence + of results, and the ability to call an Icon procedure that returns a value, which may in turn call a function that + calls Icon recursively in the same fashion.</P> + <P>These facilities also include the ability to create, activate and refresh coexpressions, the ability to write + external functions that are new string matching or string analysis functions, and the ability to work with all kinds + of Icon data as if they were built-in types. Loadfuncpp also provides garbage collection safety as a matter of + course, largely transparently to the C++ programmer. Loadfuncpp also provides a simple way to add new datatypes + to Icon using the new <A HREF="http://www.cs.arizona.edu/icon/v950/extlvals.htm" target="_blank">external values</A> + added to Icon version 9.5 in 2008. These are used extensively by loadfuncpp, and so loadfuncpp cannot be used with + versions of Icon prior to 9.5.</P> + <P>Loadfuncpp consists of three shared libraries (iload.so, loadnogpx.so and iloadgpx.so) normally placed in the + icon/bin directory (all are actually DLLs under cygwin despite the .so filename extension, and import library called + iload.a is used to link to them under cygwin) together with a small amount of Icon in loadfuncpp.icn, compiled + into loadfuncpp.u1 and loadfuncpp.u2 (using 'icont -c loadfuncpp.icn') which are normally placed in the icon/lib + directory. Loadfuncpp may then be used by an Icon program by adding the line 'link loadfuncpp' which makes the + function loadfuncpp available to Icon.</P> + <P>The function loadfuncpp is used in place of loadfunc to dynamically load external functions written to use the + loadfuncpp interface. The library containing loadfuncpp is itself loaded by an implicit call to loadfunc. The first + call to loadfuncpp loads iload.so (and also loads iloadgpx.so if the Icon installation supports graphics and iloadnogpx.so + if not) and replaces loadfuncpp by an external function in iload.so of the same name. This sequence of events makes + the C++ interface in iload.so available to all libraries subsequently loaded by Icon through calls of loadfuncpp.</P> + <H2><A NAME="Installation"></A>Installation</H2> + <P>Installation of Loadfuncpp is in three parts. First ensuring a correct Icon installation. Second placing the + loadfuncpp files appropriately. And third, ensuring that environment variables are set appropriately if the default + locations of loadfuncpp files are not used.</P> + <H3><A NAME="CorrectIconInstallation"></A>Correct Icon Installation</H3> + <P>You will need to install Icon version 9.5 Loadfuncpp to run. To verify you are running the correct version of + Icon, use `<A HREF="http://www.cs.arizona.edu/icon/refernce/icontx.htm#icont" target="_blank">icont</A> -V` and + `<A HREF="http://www.cs.arizona.edu/icon/refernce/icontx.htm#iconx" target="_blank">iconx</A> -V`. + <H3><A NAME="DefaultPlacement"></A>Default Placement of Loadfuncpp Files</H3> + <P>Loadfuncpp consists of the following files. Starting now (2010/2/8) loadfuncpp is available as an <A HREF="loadfuncpp.htm" + target="_blank">experimental source distribution.</A> I intend to do no further work on it. Use <I>make</I> and + examine the following files. + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="585"> + <TR> + <TD WIDTH="26%"> + <P>iload.so + </TD> + <TD WIDTH="74%"> + <P>C++ part of the loadfuncpp interface to <A HREF="http://www.cs.arizona.edu/icon/refernce/icontx.htm#iconx" target="_blank">iconx</A> + </TD> + </TR> + <TR> + <TD WIDTH="26%"> + <P>loadfuncpp.icn + </TD> + <TD WIDTH="74%"> + <P>Icon part of the loadfuncpp interface to <A HREF="http://www.cs.arizona.edu/icon/refernce/icontx.htm#iconx" + target="_blank">iconx</A> + </TD> + </TR> + <TR> + <TD WIDTH="26%"> + <P>iloadgpx.so + </TD> + <TD WIDTH="74%"> + <P>C++ interface needed with the graphics build of Icon + </TD> + </TR> + <TR> + <TD WIDTH="26%"> + <P>iloadnogpx.so + </TD> + <TD WIDTH="74%"> + <P>C++ interface needed with the non-graphics build of Icon + </TD> + </TR> + <TR> + <TD WIDTH="26%"> + <P>loadfuncpp.h + </TD> + <TD WIDTH="74%"> + <P>C++ header for writing new external functions + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <P>The default installation of these files is as follows. (Here we assume that the directory containing your Icon + installation is called icon.) I recommend that you use these locations unless there is a compelling reason not + to.</P> + <P> + <TABLE BORDER="0" WIDTH="585"> + <TR> + <TD WIDTH="26%"> + <P>iload.so + </TD> + <TD WIDTH="74%"> + <P>icon/bin + </TD> + </TR> + <TR> + <TD WIDTH="26%"> + <P>iload.a + </TD> + <TD WIDTH="74%"> + <P>icon/bin (cygwin only) + </TD> + </TR> + <TR> + <TD WIDTH="26%"> + <P>loadfuncpp.u1 + </TD> + <TD WIDTH="74%"> + <P>icon/lib (from loadfuncpp.icn) + </TD> + </TR> + <TR> + <TD WIDTH="26%"> + <P>loadfuncpp.u2 + </TD> + <TD WIDTH="74%"> + <P>icon/lib (from loadfuncpp.icn) + </TD> + </TR> + <TR> + <TD WIDTH="26%"> + <P>iloadgpx.so + </TD> + <TD WIDTH="74%"> + <P>icon/bin + </TD> + </TR> + <TR> + <TD WIDTH="26%"> + <P>iloadnogpx.so + </TD> + <TD WIDTH="74%"> + <P>icon/bin + </TD> + </TR> + <TR> + <TD WIDTH="26%"> + <P>loadfuncpp.h + </TD> + <TD WIDTH="74%"> + <P>wherever is convenient to #include in C++ source + </TD> + </TR> + </TABLE> +<BR> + Under <I>cygwin only</I> there is one additional file used when <A HREF="compile.htm" target="_blank">linking</A> + a dynamic library that uses loadfuncpp. This is the windows import library iload.a, and is most naturally placed + in the same directory as iload.so, as it contains the information necessary to link against it. + <H3><A NAME="AlternativePlacement"></A>Alternative Placement of Loadfuncpp Files</H3> + <P>Alternatively, you can place iload.so and iloadgpx.so anywhere you please and set the environment variable FPATH + to include the directories containing iload.so and iloadgpx.so. FPATH should be a space or colon separated string + of locations. You can compile loadfuncpp.icn using `icont -c loadfuncpp.icn` and place the resulting files (loadfuncpp.u1 + and loadfuncpp.u2) in any directory and set the environment variable IPATH to include that directory. IPATH should + also be a space or colon separated string of locations. + <H3><A NAME="LoadfuncppInstallationTest"></A>Loadfuncpp Installation Test</H3> + <P>Once loadfuncpp is installed, you may test your installation by creating a small new external function and load + and call it from Icon. Here's how.</P> + <P> + <UL> + <LI>Create a new directory, place a copy of loadfuncpp.h in it and work there + <LI>Edit a new file called (say) hello.cpp to contain the following code + <P> + <TABLE BORDER="0" WIDTH="312"> + <TR> + <TD WIDTH="312"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">#include "loadfuncpp.h" + +extern "C" int hello(value argv[]) { + argv[0] = "Hello World"; + return SUCCEEDED; +}</FONT></PRE> + </TD> + </TR> + </TABLE> + + <LI>Compile hello.cpp into a shared object hello.so using one of these <A HREF="compile.htm" target="_blank">compiler + options</A> + <LI>Edit a new file called (say) hello.icn to contain the following code and ensure that hello.so is in the same + directory + <P> + <TABLE BORDER="0" WIDTH="392"> + <TR> + <TD WIDTH="392"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">link loadfuncpp + +procedure main() + hello := loadfuncpp("./hello.so", "hello", 0) + write( hello() ) +end</FONT></PRE> + </TD> + </TR> + </TABLE> + + <LI>Compile hello.icn by typing `icont hello.icn` and run it by typing `./hello` and you should get the output + <FONT COLOR="black">Hello World</FONT> appearing in the console. + </UL> + </BLOCKQUOTE> + <BLOCKQUOTE ALIGN="CENTER"> + <UL> + <P> + </UL> + <P> + </BLOCKQUOTE> + <BLOCKQUOTE> + <H2><A NAME="Manual"></A>Manual</H2> + <P>This manual assumes that you have a <A HREF="#Installation">working installation</A> of Loadfuncpp and Icon + as described above. An installation of Icon alone is not sufficient, nor can Loadfuncpp be used with any Icon version + prior to 9.5, as it relies upon the presence of <A HREF="http://www.cs.arizona.edu/icon/v950/extlvals.htm" + target="_blank">external values</A> which are first implemented as a part of that version.</P> + <H3><A NAME="Writing"></A>Writing, Loading and Calling a new External Function</H3> + </BLOCKQUOTE> + <BLOCKQUOTE ALIGN="CENTER"> + <P>A new Icon external function written in C++ takes one of the following forms. + </BLOCKQUOTE> + <BLOCKQUOTE> + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="432"> + <TR> + <TD WIDTH="432"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">#include "loadfuncpp.h" + +extern "C" int fixed_arity(value argv[]) { + // ... has a fixed number of arguments + return SUCCEEDED; //or FAILED +} + +extern "C" int variable_arity(int argc, value argv[]){ + // ... has a variable number of arguments + return SUCCEEDED; //or FAILED +}</FONT></PRE> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <P>The C++ type 'value' is an Icon value (called a <A HREF="http://www.cs.arizona.edu/icon/current/cfuncs.htm" target="_blank">descriptor</A>), + representing null or an integer, real, string, cset, list, table, set, file, procedure, coexpression, record, <A + HREF="http://www.cs.arizona.edu/icon/v950/extlvals.htm" target="_blank">external value</A> or an Icon <A HREF="#Variable">variable</A>. + When such a function is called from Icon, its arguments are passed in the array argv starting from argv[1], and + argv[0] is taken to be the value returned to Icon by the function. In the function variable_arity the number of + arguments is also passed in argc. So the following is a one argument external function that returns its only argument. + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="432"> + <TR> + <TD WIDTH="432"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">#include "loadfuncpp.h" + +extern "C" int ident(value argv[]) { + argv[0] = argv[1]; + return SUCCEEDED; +}</FONT></PRE> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <P>The int returned to C++ is a signal to Icon indicating whether the call succeeded or failed. These are represented + by the constants SUCCEEDED and FAILED respectively, defined in loadfuncpp.h. However there is also a simple mechanism + in loadfuncpp to write <A HREF="#Generate">external functions that suspend a sequence of values</A> when called + in Icon.</P> + <P>Functions <A HREF="compile.htm" target="_blank">compiled into a shared object</A> are loaded into Icon by calls + of loadfuncpp. Such calls indicate to Icon whether the loaded function has a variable or a fixed number of arguments, + and if the latter, how many. For example the preceding functions might be loaded into Icon as follows if the body + of fixed_arity was written to use two arguments. + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="464"> + <TR> + <TD WIDTH="464"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">link loadfuncpp + +procedure main() + fixed := loadfuncpp("./mylib.so", "fixed_arity", 2) + variadic := loadfuncpp("./mylib.so", "variable_arity") + #fixed and variadic now contain Icon functions + #and may be treated like any other such values +end</FONT></PRE> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <P>If the number of arguments is not specified when loading a function of fixed <A HREF="http://en.wikipedia.org/wiki/Arity">arity</A> + then calling the result from Icon will lead to a memory violation. (Similar behavior will likely occur if a function + of variable arity is loaded with a specific arity specified, or if too small an arity is specified for a fixed + arity function.) Beware!<BR> + <BR> + A relative or absolute path to the shared object may be used as the first argument to loadfuncpp, in which case + loadfuncpp will look exactly where specified for it and nowhere else. <B>Alternatively, just the filename of the + shared object may be specified, in which case Icon will search FPATH for the file.</B> If FPATH is not set in the + environment Icon runs in, then iconx defines FPATH to consist of the current directory followed by the icon/bin + directory. If FPATH is set in the environment Icon is run in, then iconx appends the icon/bin directory. In either + case FPATH should be a space or colon separated series of directories, with no spaces in their paths. (This restriction + will be cleaned up "soon".)</P> + <P>All of the C++ in this manual requires '#include "loadfuncpp.h"' and all of the Icon requires 'link + loadfuncpp'. Hereafter this will be assumed implicitly.</P> + <P>Here is an external function of no arguments that returns null, represented in C++ by the constant nullvalue. + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="432"> + <TR> + <TD WIDTH="432"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">extern "C" int dull(value argv[]){ + argv[0] = nullvalue; + return SUCCEEDED; +}</FONT></PRE> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <P>If this is compiled into the shared object 'dull.so' in the current directory then it might be called by Icon + as follows. + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="464"> + <TR> + <TD WIDTH="464"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">dull := loadfuncpp("./dull.so", "dull", 0) +write(image( dull() ))</FONT></PRE> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <P>The value of argv[0] when an external function is called is of type procedure, and is the Icon value representing + the external function being called. So failure to assign to argv[0] means that Icon loads a function that returns + itself.</P> + <P>The C++ class <B>value</B> is intended to be used primarily in the interface to Icon. Icon structures in variables + of this class are not safe from garbage collection. Icon does guarantee that argv[] is garbage collection safe + however.</P> + <H3><A NAME="Working"></A>Working with Icon values</H3> + <P>Variables of the C++ class <B>safe</B> are intended to hold Icon values with guaranteed garbage collection safety. + The interface to Icon is largely available through the class safe. Most computation with Icon values in external + functions may be implemented through use of the <A HREF="#Operations">overloaded operators</A> in using this class, + along with its member functions that represent <A HREF="#Operations">additional Icon operators</A>. Loadfuncpp + also provides the <A HREF="#Keywords">Icon keywords</A> and in the namespace '<A HREF="#Builtin">Icon</A>' provides + a C++ variant of each of the <A HREF="#Functions">built-in functions in Icon</A>.</P> + <H4><A NAME="Initialization"></A>Assignment and Initialization among safe and value</H4> + <P>Assignment of a safe to a safe has the semantics of an Icon assignment. Specifically, if the left operand contains + an Icon value that is an <A NAME="Variable"></A>Icon <FONT COLOR="black">variable</FONT> (i.e. an Icon value used + to refer to the storage containing another Icon value so that the latter can be modified) then the assignment modifies + the value referred to by that Icon variable, not the C++ variable whose value is the Icon variable.</P> + <P>Assignment is possible among the classes safe and value, and has simple semantics: even values that are Icon + variables are copied. Initialization of variables of the class safe is possible from any of safe and value, with + the same simple semantics. In both cases the semantics is the same as Icon assignment, except in the case of an + Icon variable, which is merely copied, so that the variable assigned or initialized now contains the same Icon + variable. This lack of dereferencing is useful if an external function needs to return an Icon variable, in the + same way that an Icon procedure may.</P> + </BLOCKQUOTE> + <BLOCKQUOTE ALIGN="CENTER"> + <P>A variable of class safe may also be initialized from an array of values as follows. + </BLOCKQUOTE> + <BLOCKQUOTE> + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="432"> + <TR> + <TD WIDTH="432"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">extern "C" int makelist(int argc, value argv[]){ + safe arglist(argc, argv); + argv[0] = arglist; + return SUCCEEDED; +}</FONT></PRE> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <P>Such initialization creates an Icon list containing the values in the array starting from position 1. So the + above function called from Icon returns a list of its arguments.</P> + <P>A variable of class safe may be initialized by or assigned a C string, which causes an Icon string that is a + copy of the original to be created, so that the original can safely be modified or destroyed later. If such copying + is unwanted because the C string is a literal or constant, then the two argument value constructor may be used + as follows. + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="432"> + <TR> + <TD WIDTH="432"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">extern "C" int f(value argv[]){ + safe text = value(StringLiteral, "Hello"); + // ... + return SUCCEEDED; +}</FONT></PRE> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <P>A variable of class safe may also be initialized by or assigned a C++ long or int causing the creation of an + Icon integer. Similarly initialization or assignment of a double causes the creation of an Icon real.</P> + <H4><A NAME="Operations"></A>Icon operations on variables of class safe</H4> + <P>Here is a table of the overloaded operators and member functions implementing Icon operators for the class safe. + These are listed with their Icon equivalents, and with a note of any restrictions or extensions. The <A HREF="#Bang">unary + ! operator</A> in Icon is a generator and is supplied through loadfuncpp by <A HREF="#Bang">other means</A>.</P> + </BLOCKQUOTE> + <BLOCKQUOTE ALIGN="CENTER"> + <P> + <TABLE BORDER="0" WIDTH="585"> + <TR> + <TH COLSPAN="2"> + <P><FONT SIZE="2" FACE="Courier New, Courier">functions of safe for Icon operators</FONT> + </TH> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TH WIDTH="130"> + <P><FONT SIZE="2" FACE="Courier New, Courier">unary</FONT> + </TH> + <TH WIDTH="164"> + <P><FONT SIZE="2" FACE="Courier New, Courier">Icon equivalent</FONT> + </TH> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">*x</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">*x</FONT> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">~x</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">~x</FONT> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">-x</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">-x</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">++x</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x +:= 1</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">--x</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x -:= 1</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><B><FONT SIZE="2" FACE="Courier New, Courier">binary</FONT></B> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><B><FONT SIZE="2" FACE="Courier New, Courier">Icon equivalent</FONT></B> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">=</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">:=</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">+= -= *=</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">+:= -:= *:=</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">/= %= ^=</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">/:= %:= ^:=</FONT> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">+</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">+</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">-</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">-</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">*</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">*</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">/</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">/</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">%</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">%</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x^y</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x^y</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x | y</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x ++ y</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x & y</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x ** y</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x && y</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x -- y</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x || y</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x || y</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">|=</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">++:=</FONT> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">&=</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">**:=</FONT> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">==</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">===</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">!=</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">~===</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">< > <= >=</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><B><FONT SIZE="2" FACE="Courier New, Courier">none</FONT></B> + </TD> + <TD WIDTH="271"> + <P><A HREF="#Compare"><FONT SIZE="2" FACE="Courier New, Courier">The comparison used when sorting</FONT></A> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x[y]</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x[y]</FONT> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><B><FONT SIZE="2" FACE="Courier New, Courier">variadic</FONT></B> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><B><FONT SIZE="2" FACE="Courier New, Courier">Icon Equivalent</FONT></B> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x(...)</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x(...)</FONT> + </TD> + <TD WIDTH="271"> + <P><A HREF="#Call"><FONT SIZE="2" FACE="Courier New, Courier">Icon procedure call</FONT></A> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">(a,b ...)</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">[a,b ...]</FONT> + </TD> + <TD WIDTH="271"> + <P><A HREF="#Variadic"><FONT SIZE="2" FACE="Courier New, Courier">Variadic list construction</FONT></A> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><B><FONT SIZE="2" FACE="Courier New, Courier">member function</FONT></B> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><B><FONT SIZE="2" FACE="Courier New, Courier">Icon equivalent</FONT></B> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x.slice(y,z) </FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x[y:z]</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x.apply(y)</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x ! y</FONT> + </TD> + <TD WIDTH="271"> + <P><A HREF="#Call"><FONT SIZE="2" FACE="Courier New, Courier">Apply Icon procedure to arguments</FONT></A> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x.listcat(y)</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x ||| y</FONT> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x.swap(y)</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x :=: y</FONT> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x.create()</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">create !x</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x.create(y)</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">create x ! y</FONT> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x.activate(y)</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">y@x</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">y defaults to &null</FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x.refresh()</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">^x</FONT> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x.random()</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">?x</FONT> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x.dereference()</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">.x</FONT> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <BLOCKQUOTE> + <H4><A NAME="Functions"></A>Icon Built-in Functions</H4> + <P>All of the functions built in to Icon are available in C++ in the namespace 'Icon'. The C++ counterpart of an + Icon built-in function returns &null if the original function would have failed. Those functions that are generators + have been made to produce a single result. Those functions that are <A HREF="#Variadic">variadic</A> have been + made C++ compatible too; with a small number of arguments this can usually safely be ignored. The table below lists + each C++ variant of each Icon function that is a generator, along with a comment indicating how it has been modified + for C++ compatibility.</P> + </BLOCKQUOTE> + <BLOCKQUOTE ALIGN="CENTER"> + <P> + <TABLE BORDER="0" WIDTH="551"> + <TR> + <TH WIDTH="96"> + <P><FONT SIZE="2" FACE="Courier New, Courier">Function</FONT> + </TH> + <TD WIDTH="441"> + <P> + </TD> + </TR> + <TR> + <TD WIDTH="96"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">bal</FONT> + </TD> + <TD WIDTH="441"> + <P><FONT SIZE="2" FACE="Courier New, Courier">returns the first result generated only</FONT> + </TD> + </TR> + <TR> + <TD WIDTH="96"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">find</FONT> + </TD> + <TD WIDTH="441"> + <P><FONT SIZE="2" FACE="Courier New, Courier">returns the first result generated only</FONT> + </TD> + </TR> + <TR> + <TD WIDTH="96"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">function</FONT> + </TD> + <TD WIDTH="441"> + <P><FONT SIZE="2" FACE="Courier New, Courier">returns a list of the results originally generated</FONT> + </TD> + </TR> + <TR> + <TD WIDTH="96"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">key</FONT> + </TD> + <TD WIDTH="441"> + <P><FONT SIZE="2" FACE="Courier New, Courier">returns a list of the results originally generated</FONT> + </TD> + </TR> + <TR> + <TD WIDTH="96"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">move</FONT> + </TD> + <TD WIDTH="441"> + <P><FONT SIZE="2" FACE="Courier New, Courier">cannot be resumed</FONT> + </TD> + </TR> + <TR> + <TD WIDTH="96"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">tab</FONT> + </TD> + <TD WIDTH="441"> + <P><FONT SIZE="2" FACE="Courier New, Courier">cannot be resumed</FONT> + </TD> + </TR> + <TR> + <TD WIDTH="96"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">upto</FONT> + </TD> + <TD WIDTH="441"> + <P><FONT SIZE="2" FACE="Courier New, Courier">returns the first result generated only</FONT> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <BLOCKQUOTE> + <P>Here is an example of the use of such Icon built-in functions in a new external function. The following function + returns the set of its arguments.</P> + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="432"> + <TR> + <TD WIDTH="432"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">extern "C" int makeset(int argc, value argv[]){ + safe arglist(argc, argv); + argv[0] = Icon::set(arglist); + return SUCCEEDED; +}</FONT></PRE> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <H4><A NAME="Keywords"></A>Icon Keywords</H4> + <P>All of the Icon keywords have been made available apart from &cset (to avoid a possible name collision), + and &fail. The keywords are implemented through a keyword class with the unary '&' operator overloaded + and are used thus in C++, as in the following example.</P> + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="432"> + <TR> + <TD WIDTH="432"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">extern "C" int assignprog(value argv[]){ + safe newname(argv[1]); + &progname = newname; //Icon assignment semantics + return FAILED; +}</FONT></PRE> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <P>The preceding function assigns a new value to the keyword &progname, just as in Icon. In all cases a keyword + is used with the unary '&' operator, and therefore appears just as in an Icon program. The keywords that are + generators in Icon produce a list of values in C++.</P> + <H4><A NAME="Types"></A>Types, Conversions and Errors</H4> + <P>A well designed external function will probably do some type checking and conversions of its arguments, and + perhaps give a run-time error if they are problematic.</P> + <P>The member function <FONT COLOR="black">type()</FONT> in the value class returns one of the following constants + indicating its Icon type: <FONT COLOR="black">Null</FONT>, <FONT COLOR="black">Integer</FONT>, <A HREF="#BigInteger">BigInteger</A>, + <FONT COLOR="black">Real</FONT>, <FONT COLOR="black">Cset</FONT>, <FONT COLOR="black">File</FONT>, <FONT COLOR="black">Procedure</FONT>, + <FONT COLOR="black">Record</FONT>, <FONT COLOR="black">List</FONT>, <FONT COLOR="black">Set</FONT>, <FONT COLOR="black">Table</FONT>, + <FONT COLOR="black">String</FONT>, <FONT COLOR="black">Constructor</FONT>, <FONT COLOR="black">Coexpression</FONT>, + <FONT COLOR="black">External</FONT>, or <A HREF="#Variable">Variable</A>. Constructor means a record constructor, + and <A HREF="#BigInteger">BigInteger</A> is an integer with a binary representation larger than a machine word.</P> + <P>The member functions <FONT COLOR="black">isNull()</FONT> and <FONT COLOR="black">notNull()</FONT> in the value + class each return a boolean indicating whether or not the Icon type is null. The member functions <FONT COLOR="black">toInteger()</FONT>, + <FONT COLOR="black">toReal()</FONT>, <FONT COLOR="black">toNumeric()</FONT>, <FONT COLOR="black">toString()</FONT> + and <FONT COLOR="black">toCset()</FONT> in the value class each endeavors to perform a conversion in place to the + corresponding type following the same conventions as Icon. Each returns a boolean indicating whether the conversion + succeeded. If the conversion failed, then the Icon value remains unchanged. These functions are intended for use + with the arguments of an external function supplied to C++ before they are converted to the class safe and the + real computation begins. (The use of these functions on the entries in argv[] is garbage-collection safe because + Icon protects argv[].) For example to check that we have a string where we would need one as follows. + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="432"> + <TR> + <TD WIDTH="432"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">extern "C" int assignprog(value argv[]){ + if( !argv[1].toString() ) { + Icon::runerr(103, argv[1]); + return FAILED; //in case &error is set + } + safe newname(argv[1]); + &progname = newname; //Icon assignment semantics + return FAILED; +}</FONT></PRE> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <P>The function <FONT COLOR="black">syserror(const char*)</FONT> unconditionally and fatally terminates execution + with an Icon style error message referring to the point of execution in Icon together with the error message supplied + as a C string argument. This nicely complements <FONT COLOR="black">Icon::runerr</FONT>.<BR> + <BR> + To avoid problems with C++ conversion/overloading ambiguities, the class safe has been provided with a conversion + to the class value only, and no conversions to the types char*, int, long or double. On the other hand, the value + class has such conversions and so an explicit conversion to value can be used in many contexts to permit an implicit + conversion to a built-in type. See below for details.<BR> + <BR> + The overloaded operators for the class safe defining much of Icon's repertoire in C++ have been defined outside + the class safe, with the exception of those such as assignment, subscripting and call that C++ insists be non-static + member functions, and almost all such as well as all other member functions have parameters of type safe only. + This is so that the wide repertoire of conversions of other types to safe defined by loadfuncpp may be of maximum + utility.<BR> + <BR> + Conversions of char*, double, int and long to safe as well as value are defined, those from the built-in types + creating copies on the Icon heap. Specifically, the conversion from char* to safe or to value assumes a null terminated + C string, and produces a correspondingly copied Icon string.<BR> + <BR> + Conversions of value to long and double have been defined. These behave as expected for Icon integers and reals + respectively, but perform no conversions within Icon values (from integer to real or vice-versa). <BR> + <BR> + There is also a conversion from value to char* defined. This does <I>not</I> make a C string, but rather simply + produces a pointer to the start of an Icon string, which is not null terminated, and can move in the event of a + garbage collection. If null termination is desired, then concatenate the loadfuncpp constant value nullchar before + converting to char*, and if a copy outside of Icon is needed, then you will have to explicitly make one. Here is + an example. + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="432"> + <TR> + <TD WIDTH="432"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">extern "C" int assignprog(value argv[]){ + if( !argv[1].toString() ) { + Icon::runerr(103, argv[1]); + return FAILED; //in case &error is set + } + safe newname(argv[1]); + char* s = value(newname || nullchar); //can move + char sbuf[100]; + sprintf(sbuf, "%s", s); + //use the local copy sbuf + //... +}</FONT></PRE> + </TD> + </TR> + </TABLE> + + </BLOCKQUOTE> + <P>The non-member functions <FONT COLOR="black">bytestointeger</FONT> and <FONT COLOR="black">integertobytes</FONT> + are useful to overtly convert to and from Icon integers of any size (i.e. type <FONT COLOR="black">Integer</FONT> + or <A HREF="#BigInteger">BigInteger</A> behind the scenes). Both functions take a value and return a value. In + this context Icon strings are considered to be representations of natural numbers. Each character is considered + a base 256 digit in the obvious way, and the digits are defined to be in order from most to least significant. + The empty string represents zero. <FONT COLOR="black">bytestointeger</FONT> takes such a string and produces the + corresponding Icon integer. <FONT COLOR="black">integertobytes</FONT> takes an Icon integer and produces an Icon + string representing its absolute value in the preceding sense. Neither function attempts type conversions, so for + meaningful results they must be passed respectively a string value and an integer value.<BR> + <BR> + The non-member functions <FONT COLOR="black">base64</FONT>, <FONT COLOR="black">base64tointeger</FONT> and <FONT + COLOR="black">base64tostring</FONT> are useful to overtly convert strings and integers of any size to and from + the commonly used <A HREF="http://www.faqs.org/rfcs/rfc3548.html">base64</A> encoding. Each function takes a value + and returns a value, and none attempts any type conversion of its arguments. <FONT COLOR="black">base64</FONT> + may be passed an Icon integer or string and produces a string containing the base64 encoding thereof. The sign + of an integer is ignored, so the base64 encoding of its absolute value is produced. <FONT COLOR="black">base64tointeger</FONT> + may be passed an Icon string that is a strict base64 encoding in which case it returns the corresponding Icon integer, + and similarly <FONT COLOR="black">base64tostring</FONT> may be passed an Icon string that is a strict base64 encoding + in which case it returns the corresponding Icon string. By strict base64 encoding is meant that the string's length + is a multiple of four, that the end of the string is a sequence of between zero and two "=" characters + (used to pad the file length to a multiple of four when encoding), and apart from that the remaining characters + in the string are either lower or upper case letters, or digits, or the characters "/" and "+". + Failure to supply a string containing a strict base64 encoding to either function will cause null to be returned.</P> + <H3><A NAME="Variadic"></A><A HREF="http://en.wikipedia.org/wiki/Variadic_function">Variadic Functions</A> and + Dynamic List Construction</H3> + <P>Some built-in Icon functions take an arbitrary number of arguments. Unfortunately, C++ as of the present standard + has no convenient way to define a function with an arbitrary number of arguments of the same type. So variadic + functions included in the namespace 'Icon' such as <FONT COLOR="black">writes</FONT> are defined in two versions. + The first has at most eight arguments, with defaults and glue code to account for fewer being supplied. This takes + care of most uses of such functions.</P> + <P>The second uses a single argument of the class variadic, which is a wrapper for an Icon list of the arguments. + The operator ',' (comma) has been overloaded so as to combine two locals into a variadic, and to combine a variadic + and a safe so as to append the safe's value to the variadic's list. A variadic has a conversion to safe that in + effect removes the wrapper, and there are other sundry conversions and overloads of comma. These enable lists to + be constructed in place, providing a syntactic equivalent of things like <FONT COLOR="black">[x,y,z]</FONT> in + Icon, namely <FONT COLOR="black">(x,y,z)</FONT> in C++. The second implementation of writes may then be called + as <FONT COLOR="black">writes((x,y,z))</FONT>. The second pair of parentheses is necessary as comma is not regarded + as an operator by C++ when it is in a parameter list. Here is an example of the use of dynamic list construction.</P> + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="432"> + <TR> + <TD WIDTH="432"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">extern "C" int divide(value argv[]){ + safe x(argv[1]), y(argv[2]); + argv[0] = (x / y, x % y); + return SUCCEEDED; +}</FONT></PRE> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <H3><A NAME="Calling"></A>Calling Icon from C++</H3> + <P>The class safe has overloaded the function call operator '()' so that a safe may be called with function call + syntax. If the value of the safe is an Icon procedure (or function or record constructor) the effect is to call + Icon from C++. There are two kinds of restrictions on these calls.</P> + <P>The first restriction is because C++ requires a specific <A HREF="http://en.wikipedia.org/wiki/Arity" target="_blank">arity</A> + when overloading the function call operator, and has no convenient way to handle an arbitrary number of parameters + of the same type. This restriction is the same one affecting the calling of <A HREF="#Variadic">variadic functions</A>, + and is overcome in the same way with <A HREF="#Variadic">two implementations</A>. One with a single argument of + class variadic necessitating <A HREF="#Variadic">two pairs of parentheses</A> when the call is made, and the other + with up to eight arguments and useful for most procedure calls.</P> + <P>The second restriction is because there are three ways Icon can pass control back to a caller: by returning + a value, by failing and by suspending a value. However, there is only one way for C++ to receive control back from + a call it has made: by a value (possibly void) being returned. For this reason a call of an Icon procedure from + C++ will return &null if the procedure fails, and will return rather than suspend if the procedure suspends + a value. In either case, the call always returns cleanly with a single value. It is possible to <A HREF="#Iterate">iterate + through the values suspended by an Icon procedure</A> in C++ through a different mechanism.</P> + <H3><A NAME="Generators"></A>Working with Generators from C++</H3> + <P>Generators and the flow of control in Icon have no counterpart in C++. Nevertheless, it is useful to be able + to both implement generators for Icon in C++, and iterate through generator sequences produced by Icon in C++, + as well as create coexpressions in C++. All these facilities are provided by loadfuncpp.</P> + <H4><A NAME="Generate"></A>Writing External Functions that are Generators</H4> + <P>Here is an example of a generator function written in C++. It is a C++ implementation of the built-in Icon function + <FONT COLOR="black">seq</FONT>, without the restriction to machine size integers.</P> + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="456"> + <TR> + <TD WIDTH="456"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">class sequence: public generator { + safe current, inc; + public: + sequence(local start, local increment) { + current = start - increment; + inc = increment; + } + virtual bool hasNext() { + return true; + } + virtual value giveNext() { + return current += inc; + } +}; + +extern "C" int seq2(value argv[]){ + sequence seq(argv[1], argv[2]); + return seq.generate(argv); +}</FONT></PRE> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <P>This exemplifies all the features of loadfuncpp that enable generator functions to be written. First a C++ version + of the generator is written as a class that inherits from the loadfuncpp class generator. Some data members are + added to maintain state as generation occurs, and a constructor is written to initialize those data members. Finally + the virtual functions <FONT COLOR="black">hasNext()</FONT> and <FONT COLOR="black">giveNext()</FONT> with exactly + the above prototypes are overloaded. The sequence generated by an object of this class is defined to be that produced + by repeatedly calling <FONT COLOR="black">hasNext()</FONT> to determine if there is a next member of the sequence, + and if there is, calling <FONT COLOR="black">giveNext()</FONT> to get it.</P> + <P>Now the external function itself simply creates a generator object of the above class, presumably using values + passed to it from Icon to initialize that object's state. Then the inherited member function <FONT COLOR="black">generate</FONT> + is called, passing the original argument array for technical reasons, and the signal it returns is passed back + to Icon. The effect of this call is to iterate through the calls of <FONT COLOR="black">giveNext()</FONT> while + <FONT COLOR="black">hasNext()</FONT> returns true, suspending the results produced by each call of <FONT COLOR="black">giveNext()</FONT> + to Icon. In a nutshell the call to <FONT COLOR="black">generate</FONT> suspends the sequence of results produced + by the object to Icon. The reason that <FONT COLOR="black">generate</FONT> needs to be passed argv is that it needs + to send its results to Icon by assigning to argv[0], in just as a single result is passed back.</P> + <H4><A NAME="Iterate"></A>Calling Icon Procedures that are Generators from C++</H4> + <P>Here is an example of how to iterate over the results of a call of an Icon procedure. In the example the procedure + to be called and its argument list are presumed to be the arguments passed to the external function, which then + computes the sum of the first ten results suspended by the call, or the sum of all the results if less than ten + results are computed.</P> + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="456"> + <TR> + <TD WIDTH="456"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">class addup: public iterate { + public: + safe total; + int count; + + addup(): total(0), count(0) {} + + virtual void takeNext(const value& x) { + total += x; + } + virtual bool wantNext(const value& x) { + return ++count <= 10; + } +}; + +extern "C" int sum10(value argv[]){ + addup sum; + sum.every(argv[1], argv[2]); + argv[0] = sum.total; + return SUCCEEDED; +}</FONT></PRE> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <P>This exemplifies all the features of loadfuncpp that enable the results of a call to Icon to be iterated over + in C++. First a class representing the loop that will iterate over the generator sequence is written, inheriting + from the loadfuncpp class iterate. The data members of that class model the variables used in the loop, and the + constructor models the initialization of those loop variables. It is convenient that these be public along with + everything else; the class could be declared as a struct to achieve this. The two inherited virtual member functions + <FONT COLOR="black">wantNext()</FONT> and <FONT COLOR="black">takeNext()</FONT> with exactly the above prototypes + are then overridden. The function <FONT COLOR="black">wantNext()</FONT> models the loop condition: it returns true + if the loop will process the next result produced by the generator, and false if the loop should be terminated. + The function <FONT COLOR="black">takeNext()</FONT> models the loop body: it will be passed each result produced + by the generator, and may modify the loop variables accordingly.</P> + <P>Now the external function itself simply creates an object of this class, using the constructor to initialize + the loop variables, or simply assigning to them directly. This models setup code before the loop proper starts. + Then the inherited member function <FONT COLOR="black">every</FONT> is called with the generator function and its + argument list as arguments to the call. The call of <FONT COLOR="black">every</FONT> models executing the loop + body by calling the generator function applied to its argument list and repeatedly alternately calling <FONT COLOR="black">wantNext()</FONT> + to see if the loop should continue and <FONT COLOR="black">takeNext()</FONT> to pass the loop body the next result + produced by the call to Icon. The loop is terminated either by <FONT COLOR="black">wantNext()</FONT> returning + false or by the sequence of results generated by the call to Icon coming to an end, whichever occurs first.</P> + <H4><A NAME="Bang"></A>Iterating over Exploded Structures in C++</H4> + <P>This feature of loadfuncpp enables iteration over the results that would be generated in Icon by an expression + of the form <FONT COLOR="black">!x</FONT>, with one important difference: if <FONT COLOR="black">x</FONT> is a + table, then the results iterated over are those that would be produced by the Icon expression <FONT COLOR="black">key(x)</FONT>. + The technique use to perform such an iteration is almost identical to that used to <A HREF="#Iterate">iterate over + the results of a call to an Icon procedure</A>. The only difference is that a different inherited member function + (<FONT COLOR="black">bang</FONT>) is called to run the iteration. Here is an example that sums the first ten elements + of a list by quite unnecessarily using this technique.</P> + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="456"> + <TR> + <TD WIDTH="456"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">class addup: public iterate { + public: + safe total; + int count; + + addup(): total(0), count(0) {} + + virtual void takeNext(const value& x) { + total += x; + } + virtual bool wantNext(const value& x) { + return ++count <= 10; + } +}; + +extern "C" int sumlist(value argv[]) { + addup sum; + sum.bang(argv[1]); + argv[0] = sum.total; + return SUCCEEDED; +}</FONT></PRE> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <H4><A NAME="Coexpressions"></A>Working with Coexpressions in C++</H4> + <P>There are a handful of member functions in the class safe that provide an essentially complete set of operations + on coexpressions. These are straightforward to use and are summarized here.</P> + </BLOCKQUOTE> + <BLOCKQUOTE ALIGN="CENTER"> + <P> + <TABLE BORDER="0"> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><B><FONT SIZE="2" FACE="Courier New, Courier">safe function</FONT></B> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><B><FONT SIZE="2" FACE="Courier New, Courier">Icon equivalent</FONT></B> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x.create()</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">create !x</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier"> </FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x.create(y)</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">create x!y</FONT> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x.activate(y)</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">y@x</FONT> + </TD> + <TD WIDTH="271"> + <P><FONT SIZE="2" FACE="Courier New, Courier">y defaults to &null</FONT> + </TD> + </TR> + <TR> + <TD WIDTH="130"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">x.refresh()</FONT> + </TD> + <TD WIDTH="164"> + <P ALIGN="CENTER"><FONT SIZE="2" COLOR="black" FACE="Courier New, Courier">^x</FONT> + </TD> + <TD WIDTH="271"> + <P> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <BLOCKQUOTE> + <H3><A NAME="Externals"></A>Working with <A HREF="http://www.cs.arizona.edu/icon/v950/extlvals.htm" target="_blank">External + Values</A></H3> + <P>A new kind of external value is easily defined and used via inheritance from the loadfuncpp class external, + which permanently hides the low level machinery of the <A HREF="http://www.cs.arizona.edu/icon/v950/extlvals.htm" + target="_blank">C specification</A>. Here is an example of such that illustrates the use of the available features.</P> + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="456"> + <TR> + <TD WIDTH="456"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">class Widget: public external { + long state; + public: + Widget(long x): state(x) {} + + virtual value name() { + return "Widget"; + } + virtual external* copy() { + return new Widget(state); + } + virtual value image() { + char sbuf[100]; + sprintf(sbuf, "Widget_%ld(%ld)", id, state); + return value(NewString, sbuf); + } + virtual long compare(external* ep) { + //negative:less, zero:equal, positive:greater + Widget* wp = (Widget*)ep; + return this->state - wp->state; + } +}; + +extern "C" int widget(value argv[]) { + if( argv[1].type() != Integer ) { + Icon::runerr(101, argv[1]); + return FAILED; + } + argv[0] = new Widget(argv[1]); + return SUCCEEDED; +} + +extern "C" int widgetint(value argv[]) { + if( argv[1].type() != External ) { + Icon::runerr(131, argv[1]); + return FAILED; + } + if( !argv[1].isExternal("Widget") ) { + Icon::runerr(132, argv[1]); + return FAILED; + } + external* ep = argv[1]; //implied conversion + Widget* wp = (Widget*)ep; //can move if GC occurs! + argv[0] = ep->state; + return SUCCEEDED; +}</FONT></PRE> + </TD> + </TR> + </TABLE> +</P> + </BLOCKQUOTE> + <P>The example defines an external function <FONT COLOR="black">widget</FONT> that returns an external value to + Icon, and an external function <FONT COLOR="black">widgetint</FONT> that returns an integer extracted from a Widget + to Icon. Of course a real library would have in addition a number of external functions to work with Widgets; these + could call additional member functions in the Widget class to do the necessary work.</P> + <P>Overriding the inherited virtual functions <FONT COLOR="black">name()</FONT>, <FONT COLOR="black">copy()</FONT>, + <FONT COLOR="black">image()</FONT> and <FONT COLOR="black">compare()</FONT> automatically redefines the behavior + respectively of the built-in Icon functions type, copy and image and the Icon operators === and ~=== when applied + to Widgets, as well as the order for sorting Widgets among themselves in Icon. Such overriding is optional, and + the defaults defined in the <A HREF="http://www.cs.arizona.edu/icon/v950/extlvals.htm" target="_blank">C specification</A> + will apply otherwise. Specifically, the default copy is not to copy but to return the original.</P> + <P>There are automatic conversions to and from <FONT COLOR="black">external*</FONT> so that new widgets may be + assigned to values or safes, and vice versa when appropriate. The operator new has been overloaded so that an external + is allocated by Icon as a part of an Icon external block on the Icon heap. The class external has a protected data + member <FONT COLOR="black">id</FONT> that contains the serial number of the external value (assigned by Icon when + it allocates the external block). Using <FONT COLOR="black">id</FONT> may be convenient when overriding the <FONT + COLOR="black">image()</FONT> member function, as above.</P> + <P>External blocks are assumed by Icon not to contain any Icon <A HREF="http://www.cs.arizona.edu/icon/current/cfuncs.htm" + target="_blank">descriptors</A>, so do not declare any data members of the classes value or safe when inheriting + from external, unless you wish to invite disaster when a garbage collection occurs. Take into account that external + blocks may be relocated or garbage collected by Icon. It is not possible to arrange for a destructor or anything + else to be called when that occurs. If calling a destructor is essential, then place a pointer to the real object + in the external object, and allocate and manage the real object yourself.</P> + <H3><A NAME="Records"></A>Using Icon Records as Objects</H3> + <P>A new procedure that is a copy of another with an Icon record bound to it may be created by calling the procedure + <FONT COLOR="black">bindself</FONT>. The new procedure behaves exactly as the old one, except that a call of the + procedure <FONT COLOR="black">self</FONT> from within it returns the record attached to it by <FONT COLOR="black">bindself</FONT>. + This enables a record to contain a procedure that behaves like a method by virtue of being bound to it, as illustrated + by the following example. + <BLOCKQUOTE> + <P> + <TABLE BORDER="0" WIDTH="496"> + <TR> + <TD WIDTH="496"> + <PRE><FONT COLOR="black" FACE="Courier New, Courier">link loadfuncpp + +record object(val, print) + +procedure print() + obj := self() | fail + write( obj.val ) +end + +procedure newObject(x) + obj := object(x) #don't assign print method yet + #print will be a copy bound to the record it's embedded in + obj.print := bindself(print, obj) + return obj +end + +procedure main() + obj := newObject("Hello") + obj.print() +end</FONT></PRE> + </TD> + </TR> + </TABLE> + + </BLOCKQUOTE> + <P>Note that <FONT COLOR="black">self</FONT> fails if called from a procedure that is not bound to a record i.e. + one that has not been returned by <FONT COLOR="black">bindself</FONT>. It is possible to use bindself to bind a + record to a procedure that already has a record bound to it. This simply replaces the bound record, which is useful + for copying records that are to be treated as objects in this way, e.g. when copying a prototype object when simulating + an object based inheritance scheme. + </BLOCKQUOTE> + </TD> + </TR> +</TABLE> + +</CENTER> + +</BODY> + +</HTML> diff --git a/ipl/packs/loadfuncpp/doc/object.cpp b/ipl/packs/loadfuncpp/doc/object.cpp new file mode 100644 index 0000000..a8ac211 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/object.cpp @@ -0,0 +1,15 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int dummy(value argv[]) { + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/doc/object.icn b/ipl/packs/loadfuncpp/doc/object.icn new file mode 100644 index 0000000..5fe2ba4 --- /dev/null +++ b/ipl/packs/loadfuncpp/doc/object.icn @@ -0,0 +1,23 @@ + +link loadfuncpp + +record object(val, print) + +procedure print() + obj := self() | fail + write( obj.val ) +end + +procedure newObject(x) + obj := object(x) #don't assign print method yet + #print will be a copy bound to the record it's embedded in + obj.print := bindself(print, obj) + return obj +end + +procedure main() + obj := newObject("Hello") + obj.print() +end + + diff --git a/ipl/packs/loadfuncpp/examples/Makefile b/ipl/packs/loadfuncpp/examples/Makefile new file mode 100644 index 0000000..06bfc3f --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/Makefile @@ -0,0 +1,51 @@ + +#Automatically generated from Makefile.mak and examples.txt by ../savex.icn + +ifndef TARGET + +ifneq ($(strip $(shell g++ -v 2>&1 | grep "darwin")),) +TARGET=mac +else +ifneq ($(strip $(shell g++ -v 2>&1 | grep "cygwin")),) +TARGET=cygwin +else +TARGET=other +endif +endif + +endif + + +FLAGS_cygwin = /opt/icon/bin/iload.a -Wl,--enable-auto-import +FLAGS_other = + +SHARED_mac = -bundle -undefined suppress +SHARED_cygwin = -shared +SHARED_other = -shared + +IMPLIB_cygwin = -Wl,--out-implib=iload.a +PIC_other = -fPIC +PIC_mac = -flat_namespace + + + +EXAMPLES = callicon.exe coexp.exe extwidget.exe iterate.exe iterate2.exe iterate3.exe jmexample.exe kwd_vbl.exe methodcall.exe mkexternal.exe runerr.exe stop.exe +DYNAMICS = callicon.so coexp.so extwidget.so iterate.so iterate2.so iterate3.so jmexample.so kwd_vbl.so methodcall.so mkexternal.so runerr.so stop.so + +%.so : %.cpp loadfuncpp.h loadfuncpp.u1 + g++ $(SHARED_$(TARGET)) $(PIC_$(TARGET)) -o $@ $< $(FLAGS_$(TARGET)) + +%.exe : %.icn %.so iload.so + icont -so $@ $* + +default: $(DYNAMICS) $(EXAMPLES) + +.PHONY : iload.so loadfuncpp.h loadfuncpp.u1 + +loadfuncpp.h : ../loadfuncpp.h + cp ../loadfuncpp.h ./ + +test : clean default + +clean : + rm -f *.exe *.so *.o *% *~ core .#* *.u? diff --git a/ipl/packs/loadfuncpp/examples/Makefile.mak b/ipl/packs/loadfuncpp/examples/Makefile.mak new file mode 100644 index 0000000..28c87a3 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/Makefile.mak @@ -0,0 +1,34 @@ + +ifndef TARGET +ifneq ($(strip $(shell g++ -v 2>&1 | grep "cygwin")),) +TARGET=cygwin +else +TARGET=other +endif +endif + +FLAGS_cygwin = /opt/icon/bin/iload.a -Wl,--enable-auto-import +FLAGS_other = + +PIC_other = -fPIC + +EXAMPLES = #exe# +DYNAMICS = #so# + +%.so : %.cpp loadfuncpp.h loadfuncpp.u1 + g++ -shared $(PIC_$(TARGET)) -o $@ $< $(FLAGS_$(TARGET)) + +%.exe : %.icn %.so iload.so + icont -so $@ $* + +default: $(DYNAMICS) $(EXAMPLES) + +.PHONY : iload.so loadfuncpp.h loadfuncpp.u1 + +loadfuncpp.h : ../loadfuncpp.h + cp ../loadfuncpp.h ./ + +test : clean default + +clean : + rm -f *.exe *.so *.o *% *~ core .#* diff --git a/ipl/packs/loadfuncpp/examples/arglist.cpp b/ipl/packs/loadfuncpp/examples/arglist.cpp new file mode 100644 index 0000000..a62d347 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/arglist.cpp @@ -0,0 +1,18 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make <platform>' to build. + * For available <platform>s type 'make'. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" + + +extern "C" int iexample(int argc, value argv[]) { + safe x(argc, argv); //make the arguments into an Icon list + argv[0] = x; + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/examples/arglist.icn b/ipl/packs/loadfuncpp/examples/arglist.icn new file mode 100644 index 0000000..bb17a46 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/arglist.icn @@ -0,0 +1,7 @@ + +procedure main() + loadfunc("./iload.so", "loadfuncpp") + f := loadfunc("./iexample.so", "iexample") + every write( !( f(1,2,3,4) ) ) +end + diff --git a/ipl/packs/loadfuncpp/examples/callicon.cpp b/ipl/packs/loadfuncpp/examples/callicon.cpp new file mode 100644 index 0000000..7d0a224 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/callicon.cpp @@ -0,0 +1,18 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make <platform>' to build. + * For available <platform>s type 'make'. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" + + + +extern "C" int iexample(int argc, value argv[]) { + argv[0] = argv[1].apply(argv[2]); + return SUCCEEDED; +} + + diff --git a/ipl/packs/loadfuncpp/examples/callicon.icn b/ipl/packs/loadfuncpp/examples/callicon.icn new file mode 100644 index 0000000..c3e10ee --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/callicon.icn @@ -0,0 +1,24 @@ + +link loadfuncpp + +procedure main() + icall := loadfuncpp("./callicon.so", "iexample") + + write( icall(f, ["Argument passed"]) ) +end + +procedure f(arg) + write(arg) + write("Called from C++") + every write( g(arg) ) + x := create g(arg) + while writes(@x) + write() + return "Result string!" +end + +procedure g(arg) + suspend !arg +end + + diff --git a/ipl/packs/loadfuncpp/examples/carl.icn b/ipl/packs/loadfuncpp/examples/carl.icn new file mode 100644 index 0000000..2d7c6a4 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/carl.icn @@ -0,0 +1,50 @@ + +#here's cat in icon (line by line): + +procedure main() + while write(read()) #fails when eof +end + +#here's writing out the command line arguments + +procedure main(arg) #passed a list of strings + every write( !arg) # ! (bang) makes a generator sequence +end + +#here's finding all lines in standard input containing "frog" + +procedure main() + while line := read() do line ? #string matching subject is line + if find("frog") then write(line) +end + +#here's finding the text on each line that contains "frog" that +#lies before the first occurrence of "frog" + +procedure main() + while line := read() do line ? #string matching subject is line + write( tab(find("frog")) ) +end + +#here's generating the first 1000 squares + +procedure main() + every write( squares() ) \1000 #truncate generator to 1000 results +end + +procedure squares() + n := 0 + repeat { + n +:= 1 + suspend n^2 #shoot out next element of generator sequence + } +end + +procedure main() + (n := 1) | |( n +:= 1, n^2 ) +end + +#So that +procedure main() + every write( (n := 1) | |( n +:= 1, n^2 ) ) \1000 +end diff --git a/ipl/packs/loadfuncpp/examples/coexp.cpp b/ipl/packs/loadfuncpp/examples/coexp.cpp new file mode 100644 index 0000000..6c3b1d1 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/coexp.cpp @@ -0,0 +1,20 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make <platform>' to build. + * For available <platform>s type 'make'. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" + +extern "C" int activate(int argc, value argv[]) { + argv[0] = argv[1].activate(); + return SUCCEEDED; +} + +extern "C" int refresh(int argc, value argv[]) { + argv[0] = argv[1].refreshed(); + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/coexp.icn b/ipl/packs/loadfuncpp/examples/coexp.icn new file mode 100644 index 0000000..5f38014 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/coexp.icn @@ -0,0 +1,15 @@ + +link loadfuncpp + +procedure main() + activate := loadfuncpp("./coexp.so", "activate") + refresh := loadfuncpp("./coexp.so", "refresh") + x := create 1 to 7 + @x + @x + write( activate(x) ) + x := refresh(x) + write( activate(x) ) +end + + diff --git a/ipl/packs/loadfuncpp/examples/compare.icn b/ipl/packs/loadfuncpp/examples/compare.icn new file mode 100644 index 0000000..c6823ec --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/compare.icn @@ -0,0 +1,7 @@ + +procedure main() + loadfunc("./iload.so", "loadfuncpp") + f := loadfunc("./iexample.so", "iexample") + write( f(100,10) ) +end + diff --git a/ipl/packs/loadfuncpp/examples/examples.txt b/ipl/packs/loadfuncpp/examples/examples.txt new file mode 100644 index 0000000..40eb40a --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/examples.txt @@ -0,0 +1,12 @@ +callicon +coexp +extwidget +iterate +iterate2 +iterate3 +jmexample +kwd_vbl +methodcall +mkexternal +runerr +stop diff --git a/ipl/packs/loadfuncpp/examples/extwidget.cpp b/ipl/packs/loadfuncpp/examples/extwidget.cpp new file mode 100644 index 0000000..bb42364 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/extwidget.cpp @@ -0,0 +1,35 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +#include <cstdio> + +class Widget: public external { + long state; + public: + Widget(long x): state(x) {} + + virtual value name() { + return "Widget"; + } + virtual external* copy() { + return new Widget(state); + } + virtual value image() { + char sbuf[100]; + sprintf(sbuf, "Widget_%ld(%ld)", id, state); + return value(NewString, sbuf); + } +}; + +extern "C" int iexample(int argc, value argv[]) { + argv[0] = new Widget(99); + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/extwidget.icn b/ipl/packs/loadfuncpp/examples/extwidget.icn new file mode 100644 index 0000000..b924fd7 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/extwidget.icn @@ -0,0 +1,14 @@ + +link loadfuncpp + +procedure main() + iexample := loadfuncpp("./extwidget.so", "iexample") + external := iexample() + external2 := copy(external) + write( type(external) ) + write( image(external) ) + write( type(external2) ) + write( image(external2) ) +end + + diff --git a/ipl/packs/loadfuncpp/examples/factorials.icn b/ipl/packs/loadfuncpp/examples/factorials.icn new file mode 100644 index 0000000..908ea97 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/factorials.icn @@ -0,0 +1,27 @@ +procedure main () + every n := 1 to 10 do { + write (n, "! = ", memoized_factorial ( n ) ); + } + n := 135; write(n, "! = ", memoized_factorial ( n ) ); + n := 155; write(n, "! = ", memoized_factorial ( n ) ); +end +procedure memoized_factorial ( k ) + static results; + static k_limit; + static k_old; + initial { + results := [1]; + k_limit := 10 ^ 5; + k_old := 1; + } + if (k < k_limit) then { + while (k > *results) do results := results ||| list(*results) + every n := (k_old + 1) to k do { + results[n] := n * results[n - 1]; + } + k_old := k; + return results[k]; + } else { + return ((k / &e) ^ n) * sqrt(2 * &pi * n); + } +end diff --git a/ipl/packs/loadfuncpp/examples/hello.icn b/ipl/packs/loadfuncpp/examples/hello.icn new file mode 100644 index 0000000..5a24d9a --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/hello.icn @@ -0,0 +1,3 @@ +procedure main () + write ( "Yarrr, matey, bilge the yardarm!" ); +end diff --git a/ipl/packs/loadfuncpp/examples/hexwords.icn b/ipl/packs/loadfuncpp/examples/hexwords.icn new file mode 100644 index 0000000..43c35ca --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/hexwords.icn @@ -0,0 +1,18 @@ +procedure printable(word) + if ("" == word) then { + return ""; + } else { + return map(map(word, "oOiIzZeEsStT", "001122335577"), &lcase, &ucase); + } +end +procedure main(arg) + word_file := "/usr/share/dict/words"; + find := '0123456789abcdefABCDEFoOiIzZeEsStT'; + usage := "Finds all the words in a word file that can be written using /^[A-Fa-f0-9$/"; + words := open(word_file) | stop("Unable to open: " || word_file) + while word := trim(read(words)) do { + if ('' == word -- find) then { + write(printable(word) || " " || word); + } + } +end diff --git a/ipl/packs/loadfuncpp/examples/hexwords_oneline.icn b/ipl/packs/loadfuncpp/examples/hexwords_oneline.icn new file mode 100644 index 0000000..6e11041 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/hexwords_oneline.icn @@ -0,0 +1,8 @@ +procedure printable(word) + return "" == word | map(map(word, "oOiIzZeEsStT", "001122335577"), &lcase, &ucase); +end +procedure main() + find := '0123456789abcdefABCDEFoOiIzZeEsS'; + words := open(word_file := "/usr/share/dict/words") | stop("Unable to open: " || word_file); + every write(printable( | 1 ( | (word := trim(read(words))) , not("" == word) , ('' == word -- find)))); +end diff --git a/ipl/packs/loadfuncpp/examples/iterate.cpp b/ipl/packs/loadfuncpp/examples/iterate.cpp new file mode 100644 index 0000000..9f60d13 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/iterate.cpp @@ -0,0 +1,26 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + + +struct addup: public iterate { + safe total; + addup(): total((long)0) {} + virtual void takeNext(const value& x) { + total = total + x; + } +}; + +extern "C" int iexample(int argc, value argv[]) { + addup sum; + sum.every(argv[1], argv[2]); + argv[0] = sum.total; + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/iterate.icn b/ipl/packs/loadfuncpp/examples/iterate.icn new file mode 100644 index 0000000..0d6de0e --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/iterate.icn @@ -0,0 +1,13 @@ + +link loadfuncpp + + +procedure main() + total := loadfuncpp("./iterate.so", "iexample") + write( total(g, [1,2,3,4,5]) ) +end + +procedure g(ls[]) + suspend !ls +end + diff --git a/ipl/packs/loadfuncpp/examples/iterate2.cpp b/ipl/packs/loadfuncpp/examples/iterate2.cpp new file mode 100644 index 0000000..c32bdf9 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/iterate2.cpp @@ -0,0 +1,31 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + + +struct addup: public iterate { + safe total; + int count; + addup(): total((long)0), count(0) {} + + virtual void takeNext(const value& x) { + total = total + x; + } + virtual bool wantNext(const value& x) { + return ++count <= 3; + } +}; + +extern "C" int iexample(int argc, value argv[]) { + addup sum; + sum.every(argv[1], argv[2]); + argv[0] = sum.total; + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/iterate2.icn b/ipl/packs/loadfuncpp/examples/iterate2.icn new file mode 100644 index 0000000..3863ba1 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/iterate2.icn @@ -0,0 +1,13 @@ + +link loadfuncpp + + +procedure main() + total := loadfuncpp("./iterate2.so", "iexample") + write( total(g, [1,2,3,4,5]) ) +end + +procedure g(ls[]) + suspend !ls +end + diff --git a/ipl/packs/loadfuncpp/examples/iterate3.cpp b/ipl/packs/loadfuncpp/examples/iterate3.cpp new file mode 100644 index 0000000..1b1dd70 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/iterate3.cpp @@ -0,0 +1,32 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + + +struct addup: public iterate { + safe total; + int count; + addup(): total((long)0) { + count = 0; + } + virtual void takeNext(const value& x) { + total = total + x; + } + virtual bool wantNext(const value& x) { + return ++count <= 3; + } +}; + +extern "C" int iexample(value argv[]) { + addup sum; + sum.bang(argv[1]); + argv[0] = sum.total; + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/iterate3.icn b/ipl/packs/loadfuncpp/examples/iterate3.icn new file mode 100644 index 0000000..1f6414d --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/iterate3.icn @@ -0,0 +1,9 @@ + +link loadfuncpp + + +procedure main() + total := loadfuncpp("./iterate3.so", "iexample", 1) #arity present + write( total([1,2,3,4,5]) ) +end + diff --git a/ipl/packs/loadfuncpp/examples/jmexample.cpp b/ipl/packs/loadfuncpp/examples/jmexample.cpp new file mode 100644 index 0000000..a367fd5 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/jmexample.cpp @@ -0,0 +1,52 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make <platform>' to build. + * For available <platform>s type 'make'. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" + +enum { JMUP, JMDOWN }; +class sequence: public generator { + long count; + long limit; + int direction; + bool hasNext() { + switch(direction) { + case JMUP: + return count <= limit; + case JMDOWN: + return count >= limit; + default: + return false; + } + } + value giveNext() { + switch(direction) { + case JMUP: + return count++; + case JMDOWN: + return count--; + default: + return nullvalue; + } + } + public: + sequence(value start, value end) { + count = start; + limit = end; + direction = ((count < limit) ? JMUP : JMDOWN); + }; +}; + +extern "C" int jm_test_1(int argc, value argv[]) { + if( argc != 2 ) { + return FAILED; + } + sequence s(argv[1], argv[2]); + return s.generate(argv); +} + + diff --git a/ipl/packs/loadfuncpp/examples/jmexample.icn b/ipl/packs/loadfuncpp/examples/jmexample.icn new file mode 100644 index 0000000..d2cc973 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/jmexample.icn @@ -0,0 +1,8 @@ + +link loadfuncpp + +procedure main() + f := loadfuncpp("./jmexample.so", "jm_test_1") + every write(f(1, 10) | f(10, 1) | f(10, 10) | f(-1, 1)) +end + diff --git a/ipl/packs/loadfuncpp/examples/kwd_vbl.cpp b/ipl/packs/loadfuncpp/examples/kwd_vbl.cpp new file mode 100644 index 0000000..d754304 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/kwd_vbl.cpp @@ -0,0 +1,17 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int iexample(int argc, value argv[]) { + safe y = argv[1]; + &progname = y; + argv[0] = &progname; + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/kwd_vbl.icn b/ipl/packs/loadfuncpp/examples/kwd_vbl.icn new file mode 100644 index 0000000..4d4c9e8 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/kwd_vbl.icn @@ -0,0 +1,10 @@ + +link loadfuncpp + +procedure main() + keyword := loadfuncpp("./kwd_vbl.so", "iexample") + x := keyword("frog") + write(&progname) +end + + diff --git a/ipl/packs/loadfuncpp/examples/loadfuncpp.h b/ipl/packs/loadfuncpp/examples/loadfuncpp.h new file mode 100644 index 0000000..5704f60 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/loadfuncpp.h @@ -0,0 +1,481 @@ + +/* C++ support for easy extensions to icon via loadfunc, + * without garbage collection difficulties. + * Include this and link to iload.cpp which + * contains the necessary glue. + * See iexample.cpp for typical use. + * Carl Sturtivant, 2008/3/17 + */ + +#include<new> +#include<cstdio> + +enum kind { Null, Integer, BigInteger, Real, Cset, File, Procedure, Record, List, + Set=10, Table=12, String, Constructor, Coexpression=18, External, Variable }; + +enum special_value { NullString, StringLiteral, NewString, NullChar, Illegal }; + +enum { + SUCCEEDED = 7, // Icon function call returned: A_Continue + FAILED = 1 // Icon function call failed: A_Resume +}; + +class value; //Icon value (descriptor) +class safe; //for garbage-collection-safe Icon valued C++ variables and parameters of all kinds +class keyword; //Icon keyword represented as an object with unary & +class variadic; //for garbage-collection-safe variadic function argument lists +class proc_block; //block specifying a procedure to iconx +class external_block; //block specifying an external value to iconx +class external_ftable; //function pointers specifying external value behavior to iconx +class external; //C++ Object specifying an external value + +typedef int iconfunc(value argv[]); //type of icon built in functions or operators with a fixed number of arguments +typedef int iconfvbl(int argc, value argv[]); //type of icon built in functions with a variable number of arguments + +extern const value nullvalue; //for default arguments +extern const value nullstring; +extern const value nullchar; +extern const value illegal; //for unwanted trailing arguments +extern void syserror(const char*); //fatal termination Icon-style with error message +#define Fs_Read 0001 // file open for reading +#define Fs_Write 0002 // file open for writing +extern value IconFile(int fd, int status, char* fname); //make an Icon file descriptor +extern value integertobytes(value); //get the bytes of an Icon long integer as an Icon string (ignore sign) +extern value bytestointeger(value); //get the bytes of a new Icon long integer from an Icon string +extern value base64(value); //convert string or integer to base64 encoding (string) +extern value base64tointeger(value); //decode base64 string to integer +extern value base64tostring(value); //decode base64 string to string + +namespace Icon { +//all keywords excepting &fail, &cset (avoiding a name collision with function cset) +extern keyword allocated; +extern keyword ascii; +extern keyword clock; +extern keyword collections; +extern keyword current; +extern keyword date; +extern keyword dateline; +extern keyword digits; +extern keyword dump; +extern keyword e; +extern keyword error; +extern keyword errornumber; +extern keyword errortext; +extern keyword errorvalue; +extern keyword errout; +extern keyword features; +extern keyword file; +extern keyword host; +extern keyword input; +extern keyword lcase; +extern keyword letters; +extern keyword level; +extern keyword line; +extern keyword main; +extern keyword null; +extern keyword output; +extern keyword phi; +extern keyword pi; +extern keyword pos; +extern keyword progname; +extern keyword random; +extern keyword regions; +extern keyword source; +extern keyword storage; +extern keyword subject; +extern keyword time; +extern keyword trace; +extern keyword ucase; +extern keyword version; +}; //namespace Icon + +static void initialize_keywords(); + +class keyword { //objects representing Icon keywords + friend void initialize_keywords(); + iconfunc* f; + public: + safe operator&(); //get the keyword's value (could be an Icon 'variable') +}; + + +class value { //a descriptor with class +//data members modelled after 'typedef struct { word dword, vword; } descriptor;' from icall.h + private: + long dword; + long vword; + public: + friend class safe; + friend value IconFile(FILE* fd, int status, char* fname); + friend value integertobytes(value); + friend value bytestointeger(value); + friend value base64(value); + friend value base64tointeger(value); + friend value base64tostring(value); + value(); //&null + value(special_value, const char* text = ""); + value(int argc, value* argv); //makes a list of parameters passed in from Icon + value(int); + value(long); + value(float); + value(double); + value(char*); + value(const char*); + value(const char*, long); + value(proc_block&); + value(proc_block*); + value(external*); + operator int(); + operator long(); + operator float(); + operator double(); + operator char*(); + operator external*(); + operator proc_block*() const; + bool operator==(const value&) const; + value& dereference(); + value intify(); + bool isNull(); + bool notNull(); + bool isExternal(const value&); + value size() const; + kind type(); + bool toString(); //attempted conversion in place + bool toCset(); + bool toInteger(); + bool toReal(); + bool toNumeric(); + value subscript(const value&) const; //produces an Icon 'variable' + value& assign(const value&); //dereferences Icon style + value put(value x = nullvalue); + value push(value x = nullvalue); + void dump() const; + void printimage() const; + int compare(const value&) const; //comparator-style result: used for Icon sorting + value negative() const; // -x + value complement() const; // ~x + value refreshed() const; // ^x + value random() const; // ?x + value plus(const value&) const; + value minus(const value&) const; + value multiply(const value&) const; + value divide(const value&) const; + value remainder(const value&) const; + value power(const value&) const; + value union_(const value&) const; // x ++ y + value intersection(const value&) const; // x ** y + value difference(const value&) const; // x -- y + value concatenate(const value&) const; // x || y + value listconcatenate(const value&) const;// x ||| y + value slice(const value&, const value&) const; // x[y:z] + value& swap(value&); // x :=: y + value activate(const value& y = nullvalue) const; // y @ x ('*this' is activated) + value apply(const value&) const; // x!y (must return, not fail or suspend) +}; //class value + + +class generator { +//class to inherit from for defining loadable functions that are generators + public: + int generate(value argv[]); //call to suspend everything produced by next() + protected: //override these, and write a constructor + virtual bool hasNext(); + virtual value giveNext(); +}; //class generator + + +class iterate { +//class to inherit from for iterating over f!arg or !x + public: + void every(const value& g, const value& arg); //perform the iteration over g!arg + void bang(const value& x); //perform the iteration over !x + //override these, write a constructor and the means of recovering the answer + virtual bool wantNext(const value& x); + virtual void takeNext(const value& x); +}; + + + +class safe_variable { +//data members modelled after 'struct tend_desc' from rstructs.h + friend class value; + friend inline int safecall_0(iconfunc*, value&); + friend inline int safecall_1(iconfunc*, value&, const value&); + friend inline int safecall_2(iconfunc*, value&, const value&, const value&); + friend inline int safecall_3(iconfunc*, value&, const value&, const value&, const value&); + friend inline int safecall_4(iconfunc*, value&, const value&, const value&, const value&, const value&); + friend inline int safecall_5(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&); + friend inline int safecall_6(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&, const value&); + friend inline int safecall_v0(iconfvbl*, value&); + friend inline int safecall_v1(iconfvbl*, value&, const value&); + friend inline int safecall_v2(iconfvbl*, value&, const value&, const value&); + friend inline int safecall_v3(iconfvbl*, value&, const value&, const value&, const value&); + friend inline int safecall_vbl(iconfvbl*,safe&, const variadic&); + protected: + safe_variable *previous; + int num; + value val; + safe_variable(); + safe_variable(int); + safe_variable(long); + safe_variable(double); + safe_variable(value); + safe_variable(proc_block&); + safe_variable(proc_block*); + safe_variable(int, value*); + inline void push(safe_variable*& tendlist, int numvalues=1); + inline void pop(safe_variable*& tendlist); +}; //class safe_variable + + +class variadic: public safe_variable { + public: + variadic(int); + variadic(long); + variadic(float); + variadic(double); + variadic(char*); + variadic(value); + variadic(const safe&); + variadic(const safe&, const safe&); + variadic& operator,(const safe&); + operator value(); + ~variadic(); +}; //class variadic + + +class external_block { +//modelled on 'struct b_external' in icon/src/h/rstructs.h + friend class external; + friend class value; + static long extra_bytes; //silent extra parameter to new + long title; + long blksize; + long id; + external_ftable* funcs; + external* val; + static void* operator new(size_t); //allocated by iconx + static void operator delete(void*); //do nothing + external_block(); +}; + +class external { + friend class value; + static external_block* blockptr; //silent extra result of new + protected: + long id; + public: + static void* operator new(size_t); //allocated by new external_block() + static void operator delete(void*); //do nothing + external(); + virtual ~external() {} //root class + virtual long compare(external*); + virtual value name(); + virtual external* copy(); + virtual value image(); +}; + + +class safe: public safe_variable { +//use for a garbage collection safe icon valued safe C++ variable + friend class variadic; + friend class global; + public: + safe(); //&null + safe(const safe&); + safe(int); + safe(long); + safe(float); + safe(double); + safe(char*); + safe(const value&); + safe(const variadic&); + safe(proc_block&); + safe(proc_block*); + safe(int, value*); //from parameters sent in from Icon + ~safe(); + safe& operator=(const safe&); + //augmenting assignments here + safe& operator+=(const safe&); + safe& operator-=(const safe&); + safe& operator*=(const safe&); + safe& operator/=(const safe&); + safe& operator%=(const safe&); + safe& operator^=(const safe&); + safe& operator&=(const safe&); + safe& operator|=(const safe&); + // ++ and -- here + safe& operator++(); + safe& operator--(); + safe operator++(int); + safe operator--(int); + //conversion to value + operator value() const; + //procedure call + safe operator()(); + safe operator()(const safe&); + safe operator()(const safe& x1, const safe& x2, + const safe& x3 = illegal, const safe& x4 = illegal, + const safe& x5 = illegal, const safe& x6 = illegal, + const safe& x7 = illegal, const safe& x8 = illegal); + safe operator[](const safe&); + + friend safe operator*(const safe&); //size + friend safe operator-(const safe&); + friend safe operator~(const safe&); //set complement + friend safe operator+(const safe&, const safe&); + friend safe operator-(const safe&, const safe&); + friend safe operator*(const safe&, const safe&); + friend safe operator/(const safe&, const safe&); + friend safe operator%(const safe&, const safe&); + friend safe operator^(const safe&, const safe&); //exponentiation + friend safe operator|(const safe&, const safe&); //union + friend safe operator&(const safe&, const safe&); //intersection + friend safe operator&&(const safe&, const safe&); //set or cset difference + friend safe operator||(const safe&, const safe&); //string concatenation + friend bool operator<(const safe&, const safe&); + friend bool operator>(const safe&, const safe&); + friend bool operator<=(const safe&, const safe&); + friend bool operator>=(const safe&, const safe&); + friend bool operator==(const safe&, const safe&); + friend bool operator!=(const safe&, const safe&); + friend variadic operator,(const safe&, const safe&); //variadic argument list construction + + safe slice(const safe&, const safe&); // x[y:z] + safe apply(const safe&); // x ! y + safe listcat(const safe&); // x ||| y + safe& swap(safe&); // x :=: y + safe create(); // create !x + safe create(const safe&); // create x!y + safe activate(const safe& y = nullvalue); // y@x + safe refresh(); // ^x + safe random(); // ?x + safe dereference(); // .x + bool isIllegal() const; //is an illegal value used for trailing arguments +}; //class safe + + +//Icon built-in functions +namespace Icon { + safe abs(const safe&); + safe acos(const safe&); + safe args(const safe&); + safe asin(const safe&); + safe atan(const safe&, const safe&); + safe center(const safe&, const safe&, const safe&); + safe char_(const safe&); + safe chdir(const safe&); + safe close(const safe&); + safe collect(); + safe copy(const safe&); + safe cos(const safe&); + safe cset(const safe&); + safe delay(const safe&); + safe delete_(const safe&, const safe&); + safe detab(const variadic&); + safe detab( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe display(const safe&, const safe&); + safe dtor(const safe&); + safe entab(const variadic&); + safe entab( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe errorclear(); + safe exit(const safe&); + safe exp(const safe&); + safe flush(const safe&); + safe function(); //generative: returns a list + safe get(const safe&); + safe getch(); + safe getche(); + safe getenv(const safe&); + safe iand(const safe&, const safe&); + safe icom(const safe&); + safe image(const safe&); + safe insert(const safe&, const safe&, const safe&); + safe integer(const safe&); + safe ior(const safe&, const safe&); + safe ishift(const safe&, const safe&); + safe ixor(const safe&, const safe&); + safe kbhit(); + safe left(const safe&, const safe&, const safe&); + safe list(const safe&, const safe&); + safe loadfunc(const safe&, const safe&); + safe log(const safe&); + safe map(const safe&, const safe&, const safe&); + safe member(const safe&, const safe&); + safe name(const safe&); + safe numeric(const safe&); + safe open(const safe&, const safe&); + safe ord(const safe&); + safe pop(const safe&); + safe proc(const safe&, const safe&); + safe pull(const safe&); + safe push(const variadic&); + safe push( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe put(const variadic&); + safe put( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe read(const safe&); + safe reads(const safe&, const safe&); + safe real(const safe&); + safe remove(const safe&); + safe rename(const safe&, const safe&); + safe repl(const safe&, const safe&); + safe reverse(const safe&); + safe right(const safe&, const safe&, const safe&); + safe rtod(const safe&); + safe runerr(const safe&, const safe&); + safe runerr(const safe&); + safe seek(const safe&, const safe&); + safe serial(const safe&); + safe set(const safe&); + safe sin(const safe&); + safe sort(const safe&, const safe&); + safe sortf(const safe&, const safe&); + safe sqrt(const safe&); + safe stop(); + safe stop(const variadic&); + safe stop( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe string(const safe&); + safe system(const safe&); + safe table(const safe&); + safe tan(const safe&); + safe trim(const safe&, const safe&); + safe type(const safe&); + safe variable(const safe&); + safe where(const safe&); + safe write(); + safe write(const variadic&); + safe write( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe writes(const variadic&); + safe writes( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + //generative functions follow, crippled to return a single value + safe any(const safe&, const safe&, const safe&, const safe&); + safe many(const safe&, const safe&, const safe&, const safe&); + safe upto(const safe&, const safe&, const safe&, const safe&); + safe find(const safe&, const safe&, const safe&, const safe&); + safe match(const safe&, const safe&, const safe&, const safe&); + safe bal(const safe&, const safe&, const safe&, const safe&, const safe&, const safe&); + safe move(const safe&); + safe tab(const safe&); +}; //namespace Icon + diff --git a/ipl/packs/loadfuncpp/examples/methodcall.cpp b/ipl/packs/loadfuncpp/examples/methodcall.cpp new file mode 100644 index 0000000..0f13195 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/methodcall.cpp @@ -0,0 +1,18 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2008/3/16 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +#include<cstdio> + +extern "C" int iexample(int argc, value argv[]) { + + + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/methodcall.icn b/ipl/packs/loadfuncpp/examples/methodcall.icn new file mode 100644 index 0000000..ab48d06 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/methodcall.icn @@ -0,0 +1,23 @@ + +link loadfuncpp + + +record thing(val, method) + +procedure method(x) + object := self() | stop("not bound to a record") + object.val := x +end + +procedure main() + + obj := thing() + obj.method := bindself(method, obj) + + write(image(obj.method)) + + obj.method(99) + + write( obj.val ) +end + diff --git a/ipl/packs/loadfuncpp/examples/mkexternal.cpp b/ipl/packs/loadfuncpp/examples/mkexternal.cpp new file mode 100644 index 0000000..39c9b84 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/mkexternal.cpp @@ -0,0 +1,15 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int iexample(int argc, value argv[]) { + argv[0] = new external(); + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/mkexternal.icn b/ipl/packs/loadfuncpp/examples/mkexternal.icn new file mode 100644 index 0000000..ec388cf --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/mkexternal.icn @@ -0,0 +1,14 @@ + +link loadfuncpp + +procedure main() + iexample := loadfuncpp("./mkexternal.so", "iexample") + external := iexample() + external2 := copy(external) + write( type(external) ) + write( image(external) ) + write( type(external2) ) + write( image(external2) ) +end + + diff --git a/ipl/packs/loadfuncpp/examples/newprimes.icn b/ipl/packs/loadfuncpp/examples/newprimes.icn new file mode 100644 index 0000000..4f2391a --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/newprimes.icn @@ -0,0 +1,4 @@ +procedure main() + #limit to the first 10000 primes + every write(!(p := 1, a := [2])| 1(|(p +:= 2), not(p % !a = 0), put(a, p))) \1000 +end diff --git a/ipl/packs/loadfuncpp/examples/numbernamer.icn b/ipl/packs/loadfuncpp/examples/numbernamer.icn new file mode 100644 index 0000000..1996c8d --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/numbernamer.icn @@ -0,0 +1,61 @@ + +procedure main(arg) + every write( number(!arg, 0) ) +end + +procedure number(n, state) + static small, large, units + initial { + small := ["one", "two", "three", "four", "five", "six", "seven", "eight", + "nine", "ten", "eleven", "twelve", "thirteen", "fourteen", + "fifteen", "sixteen", "seventeen", "eighteen", "nineteen"] + large := ["ten", "twenty", "thirty", "forty", "fifty", "sixty", + "seventy", "eighty", "ninety"] + units := ["thousand", "million", "billion", "trillion", "quadrillion", + "quintillion", "sextillion", "septillion", "octillion", "nonillion"] + } + n := integer(n) | fail + if 0 = n then return "zero" + if 0 > n then return "minus " || number(-n) + if 20 > n then return small[n] + if 100 > n then { + x := n / 10 + r := n % 10 + if (0 = r) then { + return large[x] + } else { + return large[x] || "-" || number(r, state) + } + } + if (1000 > n) then { + x := n / 100 + r := n % 100 + if (0 = r) then { + return number(x, 1) || " hundred" + } else { + if (0 = state) then { + return number(x, 1) || " hundred and " || number(r, 1) + } else { + return number(x, 1) || " hundred " || number(r, 1) + } + } + } + + every i := 1 to *units do { + j := (*units - i + 1) + k := j * 3 + m := 10^k + x := n / m + r := n % m + if (0 < x) then { + if (0 = r) then { + return number(x, 1) || " " || units[j] + } else if ( 100 > r) then { + return number(x, 1) || " " || units[j] || " and " || number(r, 1) + } else { + return number(x, 1) || " " || units[j] || ", " || number(r, 0) + } + } + } + return "Error NaN: " || n +end diff --git a/ipl/packs/loadfuncpp/examples/primes.icn b/ipl/packs/loadfuncpp/examples/primes.icn new file mode 100644 index 0000000..ecbd1f1 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/primes.icn @@ -0,0 +1,26 @@ +procedure main() + #limit to the first x primes + local x; + x := 20; + every write(!(p := 1, a := [2])| 1(|(p +:= 2), not(p % !a = 0), put(a, p))) \x + list_primes(x); +end + +procedure list_primes(prime_limit) + local p; + local a; + local s; + initial { + p := 1; + a := [2]; + } + until (prime_limit <= *a) do { + p +:= 2; + s := sqrt(p); + + if (not(p % !a = 0)) then { + put(a, p); + } + } + every write(!a) +end diff --git a/ipl/packs/loadfuncpp/examples/runerr.cpp b/ipl/packs/loadfuncpp/examples/runerr.cpp new file mode 100644 index 0000000..e572133 --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/runerr.cpp @@ -0,0 +1,31 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" + +#include<stdio.h> + +extern "C" int iexample(value argv[]) { + safe callme(argv[1]), text(argv[2]); + printf("Calling callme\n"); + callme(); + printf("Callme returned\n"); + printf("Calling callme\n"); + callme(); + printf("Callme returned\n"); + //Icon::runerr(123, text); + return FAILED; +} + +extern "C" int iexample2(value argv[]) { + //Icon::display(&Icon::level, &Icon::output); + safe nextcall(argv[1]), rerr(argv[2]); + nextcall(); + rerr(123, "Bye!"); + //Icon::runerr(123, "Bye!"); + return FAILED; +} diff --git a/ipl/packs/loadfuncpp/examples/runerr.icn b/ipl/packs/loadfuncpp/examples/runerr.icn new file mode 100644 index 0000000..8c39c9a --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/runerr.icn @@ -0,0 +1,32 @@ + +link loadfuncpp + +procedure main() + x := [1,2,3] + main2() +end + +global newdisplay + +procedure main2() + newrunerr := loadfuncpp("runerr.so", "iexample", 2) + newdisplay := loadfuncpp("runerr.so", "iexample2", 2) +#&trace := -1 + newrunerr(callme, "Hello!") + write("We don't get here!") +end + +procedure callme() + initial { + write("callme() called! first time!") + return + } + write("callme() called for second time!") + newdisplay(nextcall, runerr) + #runerr(123, "callme error termination!") + return +end + +procedure nextcall() + write("Call to nextcall") +end diff --git a/ipl/packs/loadfuncpp/examples/stop.cpp b/ipl/packs/loadfuncpp/examples/stop.cpp new file mode 100644 index 0000000..74373dd --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/stop.cpp @@ -0,0 +1,16 @@ + +/* Example of a C++ extension to icon via loadfunc, + * without garbage collection difficulties. + * Type 'make iexample' to build. + * Carl Sturtivant, 2007/9/25 + */ + +#include "loadfuncpp.h" +using namespace Icon; + +extern "C" int iexample(int argc, value argv[]) { + safe x = argv[1]; + stop(x); + return SUCCEEDED; +} + diff --git a/ipl/packs/loadfuncpp/examples/stop.icn b/ipl/packs/loadfuncpp/examples/stop.icn new file mode 100644 index 0000000..6177bad --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/stop.icn @@ -0,0 +1,10 @@ + +link loadfuncpp + +procedure main() + newstop := loadfuncpp("./stop.so", "iexample") + newstop("Stop!") + write("We don't get here!") +end + + diff --git a/ipl/packs/loadfuncpp/examples/sums.icn b/ipl/packs/loadfuncpp/examples/sums.icn new file mode 100644 index 0000000..062fceb --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/sums.icn @@ -0,0 +1,8 @@ +procedure main() + local n, sum # Declare two local variables + sum := 0 # Set the sum to zero + every n := 1 to 5 do # For n equal to 1, 2, 3, 4, 5 ... + sum := sum + n; # ...add n to the sum + + write ( "The sum of all numbers from 1 to 5 is ", sum ); +end diff --git a/ipl/packs/loadfuncpp/examples/sums2.icn b/ipl/packs/loadfuncpp/examples/sums2.icn new file mode 100644 index 0000000..a5c136e --- /dev/null +++ b/ipl/packs/loadfuncpp/examples/sums2.icn @@ -0,0 +1,6 @@ +procedure main() + local sum; + sum := 0; + every sum +:= 1 to 5 + write ( "The sum of all numbers from 1 to 5 is ", sum ); +end diff --git a/ipl/packs/loadfuncpp/hex.txt b/ipl/packs/loadfuncpp/hex.txt new file mode 100644 index 0000000..d5f438c --- /dev/null +++ b/ipl/packs/loadfuncpp/hex.txt @@ -0,0 +1 @@ +2d3a674a9265858a427fb642aaf89a62 diff --git a/ipl/packs/loadfuncpp/iexample.cpp b/ipl/packs/loadfuncpp/iexample.cpp new file mode 100644 index 0000000..f51a794 --- /dev/null +++ b/ipl/packs/loadfuncpp/iexample.cpp @@ -0,0 +1,27 @@ + +#include "loadfuncpp.h" + +extern "C" int integertobytes(value argv[]) { + argv[0] = integertobytes(argv[1]); + return SUCCEEDED; +} + +extern "C" int bytestointeger(value argv[]) { + argv[0] = bytestointeger(argv[1]); + return SUCCEEDED; +} + +extern "C" int base64(value argv[]) { + argv[0] = base64(argv[1]); + return SUCCEEDED; +} + +extern "C" int base64tostring(value argv[]) { + argv[0] = base64tostring(argv[1]); + return SUCCEEDED; +} + +extern "C" int base64tointeger(value argv[]) { + argv[0] = base64tointeger(argv[1]); + return SUCCEEDED; +} diff --git a/ipl/packs/loadfuncpp/iexample.icn b/ipl/packs/loadfuncpp/iexample.icn new file mode 100644 index 0000000..1d615f3 --- /dev/null +++ b/ipl/packs/loadfuncpp/iexample.icn @@ -0,0 +1,37 @@ + +link loadfuncpp + +global integertobytes, bytestointeger, base64, base64tostring, base64tointeger + +procedure main() + integertobytes := loadfuncpp("iexample.so", "integertobytes", 1) + bytestointeger := loadfuncpp("iexample.so", "bytestointeger", 1) + base64 := loadfuncpp("iexample.so", "base64", 1) + base64tostring := loadfuncpp("iexample.so", "base64tostring", 1) + base64tointeger := loadfuncpp("iexample.so", "base64tointeger", 1) + + #test1() + test2() + #test3() +end + +procedure test3() + while write(base64tointeger(base64(integer(read())))) +end + +procedure test2() + while write(base64tostring(base64(read()))) +end + +procedure test1() + i := 16rBEADEDCEDEDBEEFEDCEDEDBEADEDBEEFED + + s := "\x00" || integertobytes(i) + ii := bytestointeger(s) + ss := integertobytes(ii) + + write( image(s) ) + write( image(ss) ) + write(i) + write(ii) +end diff --git a/ipl/packs/loadfuncpp/iload.cpp b/ipl/packs/loadfuncpp/iload.cpp new file mode 100644 index 0000000..2a39c3a --- /dev/null +++ b/ipl/packs/loadfuncpp/iload.cpp @@ -0,0 +1,2669 @@ + + +/* C++ support for easy extensions to icon via loadfunc, + * without garbage collection difficulties. + * Include loadfuncpp.h and link dynamically to + * this, which contains the necessary glue. + * See iexample.cpp for typical use. + * Carl Sturtivant, 2008/3/17 + */ + +#include <cstdio> +#include <cstring> + +#include "loadfuncpp.h" +#include "iload.h" + + +/* + * References to the part of loadfuncpp written in Icon + */ + +//variables to refer to the Icon procedures in loadfuncpp.icn +static value _loadfuncpp_pathfind; +static value _loadfuncpp_reduce; +static value _loadfuncpp_create; +static value _loadfuncpp_activate; +static value _loadfuncpp_kcollections; +static value _loadfuncpp_kfeatures; +static value _loadfuncpp_kregions; +static value _loadfuncpp_kstorage; +static value _loadfuncpp_function; +static value _loadfuncpp_key; +static value _loadfuncpp_bang; +static value _loadfuncpp_any; +static value _loadfuncpp_many; +static value _loadfuncpp_upto; +static value _loadfuncpp_find; +static value _loadfuncpp_match; +static value _loadfuncpp_bal; +static value _loadfuncpp_move; +static value _loadfuncpp_tab; +static value _loadfuncpp_apply; + +static void initialize_procs() { //called below, on load + _loadfuncpp_pathfind = Value::libproc("_loadfuncpp_pathfind"); + _loadfuncpp_reduce = Value::libproc("_loadfuncpp_reduce"); + _loadfuncpp_create = Value::libproc("_loadfuncpp_create"); + _loadfuncpp_activate = Value::libproc("_loadfuncpp_activate"); + _loadfuncpp_kcollections = Value::libproc("_loadfuncpp_kcollections"); + _loadfuncpp_kfeatures = Value::libproc("_loadfuncpp_kfeatures"); + _loadfuncpp_kregions = Value::libproc("_loadfuncpp_kregions"); + _loadfuncpp_kstorage = Value::libproc("_loadfuncpp_kstorage"); + _loadfuncpp_function = Value::libproc("_loadfuncpp_function"); + _loadfuncpp_key = Value::libproc("_loadfuncpp_key"); + _loadfuncpp_bang = Value::libproc("_loadfuncpp_bang"); + _loadfuncpp_any = Value::libproc("_loadfuncpp_any"); + _loadfuncpp_many = Value::libproc("_loadfuncpp_many"); + _loadfuncpp_upto = Value::libproc("_loadfuncpp_upto"); + _loadfuncpp_find = Value::libproc("_loadfuncpp_find"); + _loadfuncpp_match = Value::libproc("_loadfuncpp_match"); + _loadfuncpp_bal = Value::libproc("_loadfuncpp_bal"); + _loadfuncpp_move = Value::libproc("_loadfuncpp_move"); + _loadfuncpp_tab = Value::libproc("_loadfuncpp_tab"); + _loadfuncpp_apply = Value::libproc("_loadfuncpp_apply"); +} + +//callbacks to Icon for generative keywords and functions +static int K_collections(value* argv) { + argv[0] = _loadfuncpp_kcollections.apply(Value::list()); + return SUCCEEDED; +} + +static int K_features(value* argv) { + argv[0] = _loadfuncpp_kfeatures.apply(Value::list()); + return SUCCEEDED; +} + +static int K_regions(value* argv) { + argv[0] = _loadfuncpp_kregions.apply(Value::list()); + return SUCCEEDED; +} + +static int K_storage(value* argv) { + argv[0] = _loadfuncpp_kstorage.apply(Value::list()); + return SUCCEEDED; +} + +static int Z_function(value* argv) { + argv[0] = _loadfuncpp_function.apply(Value::list()); + return SUCCEEDED; +} + +static int Z_key(value* argv) { + value arg(1,argv); + argv[0] = _loadfuncpp_key.apply(arg); + return SUCCEEDED; +} + +static int Z_any(value* argv) { + value arg(4,argv); + argv[0] = _loadfuncpp_any.apply(arg); + return SUCCEEDED; +} + +static int Z_many(value* argv) { + value arg(4,argv); + argv[0] = _loadfuncpp_many.apply(arg); + return SUCCEEDED; +} + +static int Z_upto(value* argv) { + value arg(4,argv); + argv[0] = _loadfuncpp_upto.apply(arg); + return SUCCEEDED; +} + +static int Z_find(value* argv) { + value arg(4,argv); + argv[0] = _loadfuncpp_find.apply(arg); + return SUCCEEDED; +} + +static int Z_match(value* argv) { + value arg(4,argv); + argv[0] = _loadfuncpp_match.apply(arg); + return SUCCEEDED; +} + +static int Z_bal(value* argv) { + value arg(6,argv); + argv[0] = _loadfuncpp_bal.apply(arg); + return SUCCEEDED; +} + +static int Z_move(value* argv) { + value arg(1,argv); + argv[0] = _loadfuncpp_move.apply(arg); + return SUCCEEDED; +} + +static int Z_tab(value* argv) { + value arg(1,argv); + argv[0] = _loadfuncpp_tab.apply(arg); + return SUCCEEDED; +} + + + +/* + * Keywords and their initialization + */ + +namespace Icon { +//all non-graphics keywords excepting &fail, &cset (name collision with function cset) +keyword allocated; +keyword ascii; +keyword clock; +keyword collections; +keyword current; +keyword date; +keyword dateline; +keyword digits; +keyword dump; +keyword e; +keyword error; +keyword errornumber; +keyword errortext; +keyword errorvalue; +keyword errout; +keyword features; +keyword file; +keyword host; +keyword input; +keyword lcase; +keyword letters; +keyword level; +keyword line; +keyword main; +keyword null; +keyword output; +keyword phi; +keyword pi; +keyword pos; +keyword progname; +keyword random; +keyword regions; +keyword source; +keyword storage; +keyword subject; +keyword time; +keyword trace; +keyword ucase; +keyword version; +}; //namespace Icon + + +static void initialize_keywords() { + Icon::allocated.f = Kallocated; + Icon::ascii.f = Kascii; + Icon::clock.f = Kclock; + Icon::collections.f = K_collections; //generative: K_ + Icon::current.f = Kcurrent; + Icon::date.f = Kdate; + Icon::dateline.f = Kdateline; + Icon::digits.f = Kdigits; + Icon::dump.f = Kdump; + Icon::e.f = Ke; + Icon::error.f = Kerror; + Icon::errornumber.f = Kerrornumber; + Icon::errortext.f = Kerrortext; + Icon::errorvalue.f = Kerrorvalue; + Icon::errout.f = Kerrout; + Icon::features.f = K_features; //generative: K_ + Icon::file.f = Kfile; + Icon::host.f = Khost; + Icon::input.f = Kinput; + Icon::lcase.f = Klcase; + Icon::letters.f = Kletters; + Icon::level.f = Klevel; + Icon::line.f = Kline; + Icon::main.f = Kmain; + Icon::null.f = Knull; + Icon::output.f = Koutput; + Icon::phi.f = Kphi; + Icon::pi.f = Kpi; + Icon::pos.f = Kpos; + Icon::progname.f = Kprogname; + Icon::random.f = Krandom; + Icon::regions.f = K_regions; //generative: K_ + Icon::source.f = Ksource; + Icon::storage.f = K_storage; //generative: K_ + Icon::subject.f = Ksubject; + Icon::time.f = Ktime; + Icon::trace.f = Ktrace; + Icon::ucase.f = Kucase; + Icon::version.f = Kversion; +} + +safe keyword::operator&() { + value result; + safecall_0(*f, result); + return result; +} + +/* + * Implementation of the value class. + */ + +const value nullstring(NullString); +const value nullvalue; //statically initialized by default to &null +const value nullchar(NullChar); +const value illegal(Illegal); + +value::value() { +//default initialization is to &null + dword = D_Null; + vword = 0; +} + +value::value(special_value sv, const char *text) { + switch( sv ) { + case NullString: + dword = 0; + vword = (long)""; + break; + case StringLiteral: + dword = strlen(text); + vword = (long)text; + break; + case NewString: + dword = strlen(text); + vword = (long)alcstr((char*)text, dword); + break; + case NullChar: + dword = 1; + vword = (long)"\0"; + break; + case Illegal: + dword = D_Illegal; + vword = 0; + break; + default: + dword = D_Null; + vword = 0; + } +} + +value::value(int argc, value* argv) { //assumes these are passed in from Icon + safe argv0 = argv[0]; //which guarantees their GC safety + Ollist(argc, argv); + *this = argv[0]; + argv[0] = argv0; +} + +value::value(int n) { + dword = D_Integer; + vword = n; +} + +value::value(long n) { + dword = D_Integer; + vword = n; +} + +value::value(float x) { + dword = D_Real; + vword = (long)alcreal(x); +} + +value::value(double x) { + dword = D_Real; + vword = (long)alcreal(x); +} + +value::value(char* s) { + dword = strlen(s); + vword = (long)alcstr(s, dword); +} + +value::value(const char* s) { + dword = strlen(s); + vword = (long)alcstr((char*)s, dword); +} + +value::value(const char* s, long len) { + dword = len; + vword = (long)alcstr((char*)s, dword); +} + +value::value(proc_block& pb) { + dword = D_Proc; + vword = (long)&pb; +} + +value::value(proc_block* pbp) { + dword = D_Proc; + vword = (long)pbp; +} + +value::value(external* ep) { + char* ptr = (char*)ep - sizeof(external_block)/sizeof(char); + dword = D_External; + vword = (long)ptr; +} + +value::operator int() { + if( this->type() != Integer ) + syserror("loadfuncpp: int cannot be produced from non-Integer"); + return vword; +} + +value::operator long() { + if( this->type() != Integer ) + syserror("loadfuncpp: long cannot be produced from non-Integer"); + return vword; +} + +value::operator float() { + if( this->type() != Real ) + syserror("loadfuncpp: double cannot be produced from non-Real"); + return getdbl(this); +} + +value::operator double() { + if( this->type() != Real ) + syserror("loadfuncpp: double cannot be produced from non-Real"); + return getdbl(this); +} + +value::operator char*() { + if( this->type() != String ) + syserror("loadfuncpp: char* cannot be produced from non-String"); + return (char*)vword; +} + +value::operator external*() { + if( dword != D_External ) return 0; //too ruthless + return (external*)((external_block*)vword + 1); +} + +value::operator proc_block*() const { + if( dword != D_Proc ) return 0; //too ruthless + return (proc_block*)vword; +} + +void value::dump() const { + fprintf(stderr, "\n%lx\n%lx\n", dword, vword); + fflush(stderr); +} + +bool value::operator==(const value& v) const { + return dword==v.dword && vword==v.vword; +} + +value& value::dereference() { + deref(this, this); //dereference in place + return *this; +} + +value value::intify() { //integer representation of vword pointer + switch( this->type() ) { + default: + return vword; + case Null: case Integer: case Real: + return nullvalue; + } +} + +bool value::isNull() { + return (dword & TypeMask) == T_Null; +} + +bool value::notNull() { + return (dword & TypeMask) != T_Null; +} + +value value::size() const { + value result; + safecall_1(&Osize, result, *this); + return result; +} + +kind value::type() { + if( !( dword & F_Nqual ) ) return String; + if( dword & F_Var ) return Variable; + return kind(dword & TypeMask); +} + +bool value::toCset() { + return safecall_1(&Zcset, *this, *this) == SUCCEEDED; +} + +bool value::toInteger() { + return safecall_1(&Zinteger, *this, *this) == SUCCEEDED; +} + +bool value::toReal() { + return safecall_1(&Zreal, *this, *this) == SUCCEEDED; +} + +bool value::toNumeric() { + return safecall_1(&Znumeric, *this, *this) == SUCCEEDED; +} + +bool value::toString() { + return safecall_1(&Zstring, *this, *this) == SUCCEEDED; +} + +value value::subscript(const value& v) const { + value result; + safecall_2(&Osubsc, result, *this, v); + return result; +} + +value& value::assign(const value& v) { + if( dword & F_Var ) //lhs value is an Icon 'Variable' + safecall_2(&Oasgn, *this, *this, v); + else { + dword = v.dword; + vword = v.vword; + deref(this,this); //in case rhs is an Icon 'Variable' + } + return *this; +} + +value value::put(value x) { + value result; + safecall_v2(&Zput, result, *this, x); + return result; +} + +value value::push(value x) { + value result; + safecall_v2(&Zpush, result, *this, x); + return result; +} + +void value::printimage() const { + value result; + safecall_1(&Zimage, result, *this); + safecall_v1(&Zwrites, result, result); +} + +int value::compare(const value& x) const { + return anycmp(this, &x); +} + +value value::negative() const { + value result; + if( safecall_1(&Oneg, result, *this) == FAILED ) + return nullvalue; + return result; +} + +value value::complement() const { + value result; + if( safecall_1(&Ocompl, result, *this) == FAILED ) + return nullvalue; + return result; +} + +value value::refreshed() const { + value result; + if( safecall_1(&Orefresh, result, *this) == FAILED ) + return nullvalue; + return result; +} + +value value::random() const { + value result; + if( safecall_1(&Orandom, result, *this) == FAILED ) + return nullvalue; + return result; +} + +value value::plus(const value& x) const { + value result; + if( safecall_2(&Oplus, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::minus(const value& x) const { + value result; + if( safecall_2(&Ominus, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::multiply(const value& x) const { + value result; + if( safecall_2(&Omult, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::divide(const value& x) const { + value result; + if( safecall_2(&Odivide, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::remainder(const value& x) const { + value result; + if( safecall_2(&Omod, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::power(const value& x) const { + value result; + if( safecall_2(&Opowr, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::union_(const value& x) const { + value result; + if( safecall_2(&Ounion, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::intersection(const value& x) const { + value result; + if( safecall_2(&Ointer, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::difference(const value& x) const { + value result; + if( safecall_2(&Odiff, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::concatenate(const value& x) const { + value result; + if( safecall_2(&Ocater, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::listconcatenate(const value& x) const { + value result; + if( safecall_2(&Olconcat, result, *this, x) == FAILED ) + return nullvalue; + return result; +} + +value value::slice(const value& x, const value& y) const { + value result; + if( safecall_3(&Osect, result, *this, x, y) == FAILED ) + return nullvalue; + return result; +} + +value& value::swap(value& x) { + safecall_2(&Oswap, *this, *this, x); + return *this; +} + +value value::activate(const value& x) const { + value arg = Value::pair(*this, x); + return _loadfuncpp_activate.apply(arg); +} + +value value::apply(const value& x) const { + return Value::call(*this, x); +} + + + +/* + * Implementation of the generator class + */ + +int generator::generate(value argv[]) { +//suspend all values generated and return the eventual signal + int signal = FAILED; + while( this->hasNext() && signal == FAILED ) { + argv[0] = this->giveNext(); + signal = interp(SUSPEND, argv); + } + return signal; +} + +bool generator::hasNext() { return false; } //empty sequence for the root class +value generator::giveNext() { return nullvalue; } + + + +/* + * Implementation of class iterate + */ + +class wrap: public external { //an iterate object as Icon data + public: + iterate* data; + wrap(iterate* ip): data(ip) {} +}; + +extern "C" int update_iteration(value argv[]) { + external* ep = argv[1]; + iterate* ip = ((wrap*)ep)->data; + argv[0] = nullvalue; + if( ip->wantNext(argv[2]) ) { + ip->takeNext(argv[2]); + return SUCCEEDED; + } + else return FAILED; +} + +static proc_block updatepb("update_iteration", &update_iteration, 2); +static value update(updatepb); + +void iterate::every(const value& g, const value& arg) { + value nullary(new wrap(this)); + variadic v(nullary); + _loadfuncpp_reduce.apply((v,update,g,arg)); +} + +void iterate::bang(const value& x) { + value nullary(new wrap(this)); + variadic v(nullary); + _loadfuncpp_bang.apply((v,update,x)); +} + +bool iterate::wantNext(const value& v) { return true; } //use whole sequence +void iterate::takeNext(const value& v) {} + + + +/* + * Implementation of the safe_variable class + */ +safe_variable::safe_variable() : val() {}; + +safe_variable::safe_variable(int n) : val(n) {}; + +safe_variable::safe_variable(long n) : val(n) {}; + +safe_variable::safe_variable(double x) : val(x) {}; + +safe_variable::safe_variable(value v) : val(v) {}; + +safe_variable::safe_variable(proc_block& pb) : val(pb) {}; + +safe_variable::safe_variable(proc_block* pbp) : val(pbp) {}; + +safe_variable::safe_variable(int argc, value* argv) : val(argc, argv) {}; + +inline void safe_variable::push(safe_variable*& tendlist, int numvalues) { + previous = tendlist; + num = numvalues; + tendlist = this; +} + +inline void safe_variable::pop(safe_variable*& tendlist) { + if( tendlist == this ) { //we are at the head of the tend list + tendlist = tendlist->previous; //pop us off + return; + } +#if 0 + if( tendlist == tend ) //warning is for safe tend list only + { + fprintf(stderr, "loadfuncpp warning: pop needed from interior of tended list\n"); + fflush(stderr); + } +#endif + safe_variable *last = 0, *current = tendlist; + do { //search tendlist + last = current; + current = current->previous; + } while( current != this && current != 0); + if( current == 0 ) + syserror("loadfuncpp bug: failed to find variable on tended list so as to remove it."); + last->previous = current->previous; //slice us out +} + + + +/* + * Implementation of the variadic class (variable length argument list) + */ + +variadic::variadic(int n) { + value v(n); + val = Value::list(1, v); + push(global_tend); +} + +variadic::variadic(long n) { + value v(n); + val = Value::list(1, v); + push(global_tend); +} + +variadic::variadic(float x) { + value v(x); + val = Value::list(1, v); + push(global_tend); +} + +variadic::variadic(double x) { + value v(x); + val = Value::list(1, v); + push(global_tend); +} + +variadic::variadic(char* s) { + value v(s); + val = Value::list(1, v); + push(global_tend); +} + +variadic::variadic(value v) { + val = Value::list(1, v); + push(global_tend); +} + +variadic::variadic(const safe& x) { + val = Value::list(1, x.val); + push(global_tend); +} + +variadic::variadic(const safe& x, const safe& y) { + val = Value::pair(x, y); + push(global_tend); +} + +variadic& variadic::operator,(const safe& x) { + val.put(x.val); + return *this; +} + +variadic::operator value() { + return val; +} + +variadic::~variadic() { pop(global_tend); } + + +/* + * Implementation of the safe class + */ + +safe::safe() : safe_variable() { push(global_tend); } + +safe::safe(const safe& x) : safe_variable(x.val) { push(global_tend); } + +safe::safe(int n) : safe_variable(n) { push(global_tend); } + +safe::safe(long n) : safe_variable(n) { push(global_tend); } + +safe::safe(float x) : safe_variable(x) { push(global_tend); } + +safe::safe(double x) : safe_variable(x) { push(global_tend); } + +safe::safe(char* s) : safe_variable(s) { push(global_tend); } + +safe::safe(const value& v) : safe_variable(v) { push(global_tend); } + +safe::safe(const variadic& v) : safe_variable(v) { push(global_tend); } + +safe::safe(proc_block& pb) : safe_variable(pb) { push(global_tend); } + +safe::safe(proc_block* pbp) : safe_variable(pbp) { push(global_tend); } + +safe::safe(int argc, value* argv) : safe_variable(argc, argv) { push(global_tend); } + +safe::~safe() { pop(global_tend); } + +safe& safe::operator=(const safe& x) { + val.assign(x.val); //Icon style assignment + return *this; +} + +safe& safe::operator^=(const safe& x) { + *this = *this ^ x; + return *this; +} + +safe& safe::operator+=(const safe& x) { + *this = *this + x; + return *this; +} + +safe& safe::operator-=(const safe& x) { + *this = *this - x; + return *this; +} + +safe& safe::operator*=(const safe& x) { + *this = *this * x; + return *this; +} + +safe& safe::operator/=(const safe& x) { + *this = *this / x; + return *this; +} + +safe& safe::operator%=(const safe& x) { + *this = *this % x; + return *this; +} + +safe& safe::operator&=(const safe& x) { + *this = *this & x; + return *this; +} + +safe& safe::operator|=(const safe& x) { + *this = *this | x; + return *this; +} + +safe& safe::operator++() { + *this -= 1; + return *this; +} + +safe& safe::operator--() { + *this += 1; + return *this; +} + +safe safe::operator++(int) { + safe temp(*this); + *this += 1; + return temp; +} + +safe safe::operator--(int) { + safe temp(*this); + *this -= 1; + return temp; +} + +safe::operator value() const { + return val; //low-level copy +} + +safe safe::operator() () { + value empty = Value::list(); + return this->apply(empty); +} + +safe safe::operator() (const safe& x) { + value singleton = Value::list(1, x); + return this->apply(singleton); +} + +safe safe::operator()(const safe& x1, const safe& x2, + const safe& x3, const safe& x4, + const safe& x5, const safe& x6, + const safe& x7, const safe& x8 ) { + if( x3.isIllegal() ) + return this->apply( (x1,x2) ); + if( x4.isIllegal() ) + return this->apply( (x1,x2,x3) ); + if( x5.isIllegal() ) + return this->apply( (x1,x2,x3,x4) ); + if( x6.isIllegal() ) + return this->apply( (x1,x2,x3,x4,x5) ); + if( x7.isIllegal() ) + return this->apply( (x1,x2,x3,x4,x5,x6) ); + if( x8.isIllegal() ) + return this->apply( (x1,x2,x3,x4,x5,x6,x7) ); + return this->apply( (x1,x2,x3,x4,x5,x6,x7,x8) ); +} + +safe safe::operator[](const safe& x) { + return val.subscript(x.val); +} + +safe operator*(const safe& x){ + return x.val.size(); +} + +safe operator-(const safe& x){ + return x.val.negative(); +} + +safe operator~(const safe& x){ //set complement + return x.val.complement(); +} + +safe operator+(const safe& x, const safe& y){ + return x.val.plus(y.val); +} + +safe operator-(const safe& x, const safe& y){ + return x.val.minus(y.val); +} + +safe operator*(const safe& x, const safe& y){ + return x.val.multiply(y.val); +} + +safe operator/(const safe& x, const safe& y){ + return x.val.divide(y.val); +} + +safe operator%(const safe& x, const safe& y){ + return x.val.remainder(y.val); +} + +safe operator^(const safe& x, const safe& y){ //exponentiation + return x.val.power(y.val); +} + +safe operator|(const safe& x, const safe& y){ //union + return x.val.union_(y.val); +} + +safe operator&(const safe& x, const safe& y){ //intersection + return x.val.intersection(y.val); +} + +safe operator&&(const safe& x, const safe& y){ //set or cset difference + return x.val.difference(y.val); +} + +safe operator||(const safe& x, const safe& y){ //string concatenation + return x.val.concatenate(y.val); +} + +bool operator<(const safe& x, const safe& y){ + return x.val.compare(y.val) < 0; +} + +bool operator>(const safe& x, const safe& y){ + return x.val.compare(y.val) > 0; +} + +bool operator<=(const safe& x, const safe& y){ + return x.val.compare(y.val) <= 0; +} + +bool operator>=(const safe& x, const safe& y){ + return x.val.compare(y.val) >= 0; +} + +bool operator==(const safe& x, const safe& y){ + return x.val.compare(y.val) == 0; +} + +bool operator!=(const safe& x, const safe& y){ + return x.val.compare(y.val) != 0; +} + +variadic operator,(const safe& x, const safe& y){ //variadic argument list construction + return variadic(x.val, y.val); +} + +safe safe::slice(const safe& y, const safe& z){ // x[y:z] + return this->val.slice(y, z); +} + +safe safe::apply(const safe& y){ // x ! y + safe result; + result = _loadfuncpp_apply.apply( (this->val, y.val) ); + return result; +} + +safe safe::listcat(const safe& y){ // x ||| y + value x(*this); + return x.listconcatenate(y); +} + +safe& safe::swap(safe& y){ // x :=: y + value& x(this->val); + value& yv(y.val); + x.swap(yv); + return *this; +} + +safe safe::create(){ // create !x + return _loadfuncpp_create.apply(Value::list(1, *this)); +} + +safe safe::create(const safe& y){ // create x!y + return _loadfuncpp_create.apply(Value::pair(*this, y)); +} + +safe safe::activate(const safe& y){ // y@x + return _loadfuncpp_activate.apply(Value::pair(*this, y)); +} + +safe safe::refresh(){ // ^x + return this->val.refreshed(); +} + +safe safe::random(){ // ?x + return this->val.random(); +} + +safe safe::dereference(){ // .x + value var(this->val); + var.dereference(); + return var; +} + +bool safe::isIllegal() const { + return this->val == illegal; +} + + + +/* + * iconx callback support + */ + +inline int safecall_0(iconfunc *F, value& out) { + struct { + safe_variable tend; //contains an additional unused value + value stack[1]; + } vars; + vars.stack[0] = nullvalue; + vars.tend.push(tend,2); + int result = F(vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_1(iconfunc *F, value& out, const value& x1) { + struct { + safe_variable tend; //contains an additional unused value + value stack[2]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.tend.push(tend,3); + int result = F(vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_2(iconfunc *F, value& out, const value& x1, const value& x2) { + struct { + safe_variable tend; //contains an additional unused value + value stack[3]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.stack[2] = x2; + vars.tend.push(tend,4); + int result = F(vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_3(iconfunc *F, value& out, const value& x1, const value& x2, const value& x3) { + struct { + safe_variable tend; //contains an additional unused value + value stack[4]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.stack[2] = x2; + vars.stack[3] = x3; + vars.tend.push(tend,5); + int result = F(vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_4(iconfunc *F, value& out, const value& x1, const value& x2, const value& x3, const value& x4) { + struct { + safe_variable tend; //contains an additional unused value + value stack[5]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.stack[2] = x2; + vars.stack[3] = x3; + vars.stack[4] = x4; + vars.tend.push(tend,6); + int result = F(vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_5(iconfunc *F, value& out, const value& x1, const value& x2, const value& x3, const value& x4, const value& x5) { + struct { + safe_variable tend; //contains an additional unused value + value stack[6]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.stack[2] = x2; + vars.stack[3] = x3; + vars.stack[4] = x4; + vars.stack[5] = x5; + vars.tend.push(tend,7); + int result = F(vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_6(iconfunc *F, value& out, const value& x1, const value& x2, const value& x3, const value& x4, const value& x5, const value& x6) { + struct { + safe_variable tend; //contains an additional unused value + value stack[7]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.stack[2] = x2; + vars.stack[3] = x3; + vars.stack[4] = x4; + vars.stack[5] = x5; + vars.stack[6] = x6; + vars.tend.push(tend,8); + int result = F(vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_v0(iconfvbl *F, value& out) { + struct { + safe_variable tend; //contains an additional unused value + value stack[1]; + } vars; + vars.stack[0] = nullvalue; + vars.tend.push(tend,2); + int result = F(0, vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_v1(iconfvbl *F, value& out, const value& x1) { + struct { + safe_variable tend; //contains an additional unused value + value stack[2]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1]= x1; + vars.tend.push(tend,3); + int result = F(1, vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_v2(iconfvbl *F, value& out, const value& x1, const value& x2) { + struct { + safe_variable tend; //contains an additional unused value + value stack[3]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.stack[2] = x2; + vars.tend.push(tend,4); + int result = F(2, vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_v3(iconfvbl *F, value& out, const value& x1, const value& x2, const value& x3) { + struct { + safe_variable tend; //contains an additional unused value + value stack[4]; + } vars; + vars.stack[0] = nullvalue; + vars.stack[1] = x1; + vars.stack[2] = x2; + vars.stack[3] = x3; + vars.tend.push(tend,5); + int result = F(3, vars.stack); + if( result == SUCCEEDED ) + out = vars.stack[0]; + vars.tend.pop(tend); + return result; +} + +inline int safecall_vbl(iconfvbl* F, safe& out, const variadic& arg) { + int argc = arg.val.size(); + //C++ makes allocating trailing variable sized arrays + //inside structs difficult, so do this C-style + safe_variable* pvars = (safe_variable*)malloc(sizeof(safe_variable)+(argc+1)*sizeof(value)); + value* stack = (value*)(pvars + 1); //get past the safe_variable at the start of the block + stack[0] = nullvalue; + for(int i=1; i<=argc; ++i) + stack[i] = arg.val.subscript(i).dereference(); + pvars->push(tend, argc+2); + int result = F(argc, stack); + if( result == SUCCEEDED ) + out = stack[0]; + pvars->pop(tend); + free(pvars); +} + + + +/* + * Procedure related + */ + +//Icon procedure block: used to make new Icon procedures as values to return + +proc_block::proc_block(value procname, iconfvbl *function) { + init(procname); + nparam = -1; //a variable number of arguments + entryp = function; +} + +proc_block::proc_block(value procname, iconfunc *function, int arity) { + init(procname); + nparam = arity; + entryp = (iconfvbl*)function; +} + +proc_block::proc_block(value procname, iconfvbl *function, int arity) { + init(procname); + nparam = -1; //a variable number of arguments + entryp = function; +} + +long proc_block::extra_bytes = 0; + +extern long extl_ser; //serial number counter for alcexternal + +static void* alcproc(long nbytes) { + proc_block* pbp = (proc_block*)alcexternal(nbytes, 0, 0); //a hack for now + --extl_ser; + pbp->title = T_Proc; + pbp->blksize = nbytes; + return (void*)pbp; +} + +void* proc_block::operator new(size_t nbytes) { //allocated in Icon's block region + return alcproc(nbytes + extra_bytes); +} + +void proc_block::operator delete(void*) { + return; //do nothing +} + +proc_block::proc_block(proc_block* pbp) { + *this = *pbp; //copy the C++ legitimate part +} + +proc_block* proc_block::bind(proc_block* pbp, const value& rec) { + extra_bytes = pbp->blksize - sizeof(proc_block) + sizeof(value); //one more slot + proc_block* ans = new proc_block(pbp); // copies the C++ legitimate part + ans->blksize = sizeof(proc_block) + extra_bytes; + extra_bytes = 0; + int nsafe = ans->ndynam + ans->nparam; + for( int pos=1; pos<nsafe; pos++) //copy the remainder + ans->lnames[pos] = pbp->lnames[pos]; + ans->lnames[nsafe] = rec; //set the last array slot to rec + ans->pname = "bound to record"; //improve this to use the proc name and rec image + return ans; +} + +extern "C" int bindself(value argv[]) { + if( argv[1].type() != Procedure || + argv[2].type() != Record ) { + argv[0] = nullvalue; + return FAILED; + } + argv[0] = proc_block::bind(argv[1], argv[2]); + return SUCCEEDED; +} + + + +/* + * External values related + */ + +extern "C" { //these call virtual functions, so only one function list needed + static int extcmp(int argc, value argv[]) { + external *ep = argv[1], *ep2 = argv[2]; + argv[0] = ep->compare(ep2); + return 0; + } + static int extcopy(int argc, value argv[]) { + external* ep = argv[1]; + argv[0] = ep->copy(); + return 0; + } + static int extname(int argc, value argv[]) { + external* ep = argv[1]; + argv[0] = ep->name(); + return 0; + } + static int extimage(int argc, value argv[]) { + external* ep = argv[1]; + argv[0] = ep->image(); + return 0; + } +}; //end extern "C" + +static void initialize_ftable(); //just below + +static struct external_ftable { //C callback table for all C++ made external values + iconfvbl* cmp; + iconfvbl* copy; + iconfvbl* name; + iconfvbl* image; + external_ftable() { initialize_ftable(); } +} ftable; + +static void initialize_ftable() { + ftable.cmp = &extcmp; + ftable.copy = &extcopy; + ftable.name = &extname; + ftable.image = &extimage; +} + +long external_block::extra_bytes; //silent extra parameter to external_block::new + +static void* external_block::operator new(size_t nbytes) { + return alcexternal(nbytes + extra_bytes, &ftable, 0); //extra_bytes for C++ external +} + +static void external_block::operator delete(void* p) { + return; //don't delete +} + +external_block::external_block() { + //val = (external*)((long*)&val + 1); //add a trashable pointer to the (to be appended) external + val = 0; +} + +external_block* external::blockptr; //silent extra result of external::new for external() + +static void* external::operator new(size_t nbytes) { + external_block::extra_bytes = nbytes; //pass our requirements to external_block::new + blockptr = new external_block(); //with extra_bytes; pass our requirements to external() + char* ptr = (char*)blockptr + sizeof(external_block)/sizeof(char); //beginning of extra_bytes + return (void*)ptr; //where the external will be appended +} + +static void external::operator delete(void* p) { + return; //don't delete +} + +external::external() { + id = blockptr->id; //set by new +} + +external* external::copy() { + return this; +} + +value external::image() { //need new string every time! + char sbuf[100]; + long vptr = *((long*)this); + sprintf(sbuf, "external_%ld(%lX)", id, vptr); + return value(NewString, sbuf); +} + +value external::name() { + return value(StringLiteral, "external"); +} + +long external::compare(external* ep) { + return this->id - ep->id; +} + +bool value::isExternal(const value& type) { //needs external_block declaration + if( dword != D_External ) return false; + value result; + external_block* ebp = (external_block*)vword; + iconfvbl* name = (ebp->funcs)->name; + value stack[2]; + stack[1] = *this; + name(1, stack); + return !stack[0].compare(type); +} + + + +/* + * Startup code (on load) + */ + +//new variant of loadfunc sidestepping loadfunc's glue, a three argument function + +extern "C" int loadfuncpp(value argv[]) { //three arguments + if( argv[3].isNull() ) argv[3]=-1; + //assumption: a path is specified iff a slash or backslash is in the filename, + if( argv[1].toString() ) { + safe fname(argv[1]), fullname; + int ispath = value( *(Icon::cset(fname) & Icon::cset((char*)"\\/")) ); + if( !ispath ) { //search FPATH for the file + fullname = _loadfuncpp_pathfind.apply((fname, Icon::getenv((char*)"FPATH"))); + if( fullname == nullvalue ) { + Icon::runerr(216, argv[1]); + return FAILED; + } + argv[1] = value(fullname); + } + } + return rawloadfuncpp(argv); +} + +static void replace_loadfunc() { + static proc_block pb("loadfuncpp", loadfuncpp, 3); //three arguments + value proc(pb), var = Value::variable("loadfunc"); + var.assign(proc); +} + +//set up a tend list for global variables on the tail of &main's +struct safe_tend { //struct with isomorphic data footprint to a safe_variable + safe_variable *previous; + int num; + value val; +} sentinel; + +safe_variable*& global_tend = sentinel.previous; + +static void add_to_end(safe_variable*& tend_list) { + safe_tend *last = 0, *current = (safe_tend*)tend_list; + while( current != 0 ) { + last = current; + current = (safe_tend*)(current->previous); + } + if( last == 0 ) tend_list = (safe_variable*)&sentinel; + else last->previous = (safe_variable*)&sentinel; +} + +static void make_global_tend_list() { + sentinel.previous = 0; + sentinel.num = 1; + sentinel.val = nullvalue; + if( k_current == k_main ) add_to_end(tend); //add to the active tend list + else add_to_end( ((coexp_block*)(long(k_main)))->es_tend ); +} + +struct load { + load() { //startup code here + replace_loadfunc(); //store loadfuncpp in global loadfunc temporarily + make_global_tend_list(); + initialize_procs(); + initialize_keywords(); +//fprintf(stderr, "\nStartup code ran!\n");fflush(stderr); + } +}; +static load startup; //force static initialization so as to run startup code + + + +/* + * Useful helper functions + */ + +namespace Value { + +value pair(value x, value y) { + value newlist; + if( safecall_v2(&Ollist, newlist, x, y) == FAILED ) + return nullvalue; + return newlist; +} + +value list(value n, value init) { + value newlist; + if( safecall_2(&Zlist, newlist, n, init) == FAILED ) + return nullvalue; + return newlist; +} + +void runerr(value n, value x) { + value v; + safecall_v2(&Zrunerr, v, n, x); +} + +value set(value list) { + value newset; + if( safecall_1(&Zset, newset, list) == FAILED ) + return nullvalue; + return newset; +} + +value table(value init) { + value newtable; + if( safecall_1(&Ztable, newtable, init) == FAILED ) + return nullvalue; + return newtable; +} + +value variable(value name) { + value var; + if( safecall_1(&Zvariable, var, name) == FAILED ) + return nullvalue; + return var; +} + +value proc(value name, value arity) { + value procedure; + if( safecall_2(&Zproc, procedure, name, arity) == FAILED ) + return nullvalue; + return procedure; +} + +value libproc(value name, value arity) { + value procedure; + if( safecall_2(&Zproc, procedure, name, arity) == SUCCEEDED ) + return procedure; + syserror("loadfuncpp: unable to find required Icon procedure through 'link loadfunc'\n"); + return nullvalue; +} + +}; //namespace Value + + + +/* + * Built-in Icon functions + */ +namespace Icon { +safe abs(const safe& x1) { + value result; + safecall_1(&Zabs, result, x1); + return result; +} + +safe acos(const safe& x1) { + value result; + safecall_1(&Zacos, result, x1); + return result; +} + +safe args(const safe& x1) { + value result; + safecall_1(&Zargs, result, x1); + return result; +} + +safe asin(const safe& x1) { + value result; + safecall_1(&Zasin, result, x1); + return result; +} + +safe atan(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zatan, result, x1, x2); + return result; +} + +safe center(const safe& x1, const safe& x2, const safe& x3) { + value result; + safecall_3(&Zcenter, result, x1, x2, x3); + return result; +} + +safe char_(const safe& x1) { + value result; + safecall_1(&Zchar, result, x1); + return result; +} + +safe chdir(const safe& x1) { + value result; + safecall_1(&Zchdir, result, x1); + return result; +} + +safe close(const safe& x1) { + value result; + safecall_1(&Zclose, result, x1); + return result; +} + +safe collect() { + value result; + safecall_0(&Zcollect, result); + return result; +} + +safe copy(const safe& x1) { + value result; + safecall_1(&Zcopy, result, x1); + return result; +} + +safe cos(const safe& x1) { + value result; + safecall_1(&Zcos, result, x1); + return result; +} + +safe cset(const safe& x1) { + value result; + safecall_1(&Zcset, result, x1); + return result; +} + +safe delay(const safe& x1) { + value result; + safecall_1(&Zdelay, result, x1); + return result; +} + +safe delete_(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zdelete, result, x1, x2); + return result; +} + +safe detab(const variadic& x1) { + safe result; + safecall_vbl(&Zdetab, result, x1); + return result; +} + +safe detab( const safe& x1, const safe& x2, + const safe& x3, const safe& x4, + const safe& x5, const safe& x6, + const safe& x7, const safe& x8 ) { + if( x3.isIllegal() ) + return detab( (x1,x2) ); + if( x4.isIllegal() ) + return detab( (x1,x2,x3) ); + if( x5.isIllegal() ) + return detab( (x1,x2,x3,x4) ); + if( x6.isIllegal() ) + return detab( (x1,x2,x3,x4,x5) ); + if( x7.isIllegal() ) + return detab( (x1,x2,x3,x4,x5,x6) ); + if( x8.isIllegal() ) + return detab( (x1,x2,x3,x4,x5,x6,x7) ); + return detab( (x1,x2,x3,x4,x5,x6,x7,x8) ); +} + +safe display(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zdisplay, result, x1, x2); + return result; +} + +safe dtor(const safe& x1) { + value result; + safecall_1(&Zdtor, result, x1); + return result; +} + +safe entab(const variadic& x1) { + safe result; + safecall_vbl(&Zentab, result, x1); + return result; +} + +safe errorclear() { + value result; + safecall_0(&Zerrorclear, result); + return result; +} + +safe exit(const safe& x1) { + value result; + safecall_1(&Zexit, result, x1); + return result; +} + +safe exp(const safe& x1) { + value result; + safecall_1(&Zexp, result, x1); + return result; +} + +safe flush(const safe& x1) { + value result; + safecall_1(&Zflush, result, x1); + return result; +} + +safe function() { + value result; + safecall_0(&Z_function, result); //generative: Z_ + return result; +} + +safe get(const safe& x1) { + value result; + safecall_1(&Zget, result, x1); + return result; +} + +safe getch() { + value result; + safecall_0(&Zgetch, result); + return result; +} + +safe getche() { + value result; + safecall_0(&Zgetche, result); + return result; +} + +safe getenv(const safe& x1) { + value result; + safecall_1(&Zgetenv, result, x1); + return result; +} + +safe iand(const safe& x1, const safe& x2) { + value result; + safecall_2(&Ziand, result, x1, x2); + return result; +} + +safe icom(const safe& x1) { + value result; + safecall_1(&Zicom, result, x1); + return result; +} + +safe image(const safe& x1) { + value result; + safecall_1(&Zimage, result, x1); + return result; +} + +safe insert(const safe& x1, const safe& x2, const safe& x3) { + value result; + safecall_3(&Zinsert, result, x1, x2, x3); + return result; +} + +safe integer(const safe& x1) { + value result; + safecall_1(&Zinteger, result, x1); + return result; +} + +safe ior(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zior, result, x1, x2); + return result; +} + +safe ishift(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zishift, result, x1, x2); + return result; +} + +safe ixor(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zixor, result, x1, x2); + return result; +} + +safe kbhit() { + value result; + safecall_0(&Zkbhit, result); + return result; +} + +safe key(const safe& x1) { + value result; + safecall_1(&Z_key, result, x1); //generative: Z_ + return result; +} + +safe left(const safe& x1, const safe& x2, const safe& x3) { + value result; + safecall_3(&Zleft, result, x1, x2, x3); + return result; +} + +safe list(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zlist, result, x1, x2); + return result; +} + +safe loadfunc(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zloadfunc, result, x1, x2); + return result; +} + +safe log(const safe& x1) { + value result; + safecall_1(&Zlog, result, x1); + return result; +} + +safe map(const safe& x1, const safe& x2, const safe& x3) { + value result; + safecall_3(&Zmap, result, x1, x2, x3); + return result; +} + +safe member(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zmember, result, x1, x2); + return result; +} + +safe name(const safe& x1) { + value result; + safecall_1(&Zname, result, x1); + return result; +} + +safe numeric(const safe& x1) { + value result; + safecall_1(&Znumeric, result, x1); + return result; +} + +safe open(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zopen, result, x1, x2); + return result; +} + +safe ord(const safe& x1) { + value result; + safecall_1(&Zord, result, x1); + return result; +} + +safe pop(const safe& x1) { + value result; + safecall_1(&Zpop, result, x1); + return result; +} + +safe proc(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zproc, result, x1, x2); + return result; +} + +safe pull(const safe& x1) { + value result; + safecall_1(&Zpull, result, x1); + return result; +} + +safe push(const variadic& x1) { + safe result; + safecall_vbl(&Zpush, result, x1); + return result; +} + +safe push( const safe& x1, const safe& x2, + const safe& x3, const safe& x4, + const safe& x5, const safe& x6, + const safe& x7, const safe& x8 ) { + if( x3.isIllegal() ) + return push( (x1,x2) ); + if( x4.isIllegal() ) + return push( (x1,x2,x3) ); + if( x5.isIllegal() ) + return push( (x1,x2,x3,x4) ); + if( x6.isIllegal() ) + return push( (x1,x2,x3,x4,x5) ); + if( x7.isIllegal() ) + return push( (x1,x2,x3,x4,x5,x6) ); + if( x8.isIllegal() ) + return push( (x1,x2,x3,x4,x5,x6,x7) ); + return push( (x1,x2,x3,x4,x5,x6,x7,x8) ); +} + +safe put(const variadic& x1) { + safe result; + safecall_vbl(&Zput, result, x1); + return result; +} + +safe put( const safe& x1, const safe& x2, + const safe& x3, const safe& x4, + const safe& x5, const safe& x6, + const safe& x7, const safe& x8 ) { + if( x3.isIllegal() ) + return put( (x1,x2) ); + if( x4.isIllegal() ) + return put( (x1,x2,x3) ); + if( x5.isIllegal() ) + return put( (x1,x2,x3,x4) ); + if( x6.isIllegal() ) + return put( (x1,x2,x3,x4,x5) ); + if( x7.isIllegal() ) + return put( (x1,x2,x3,x4,x5,x6) ); + if( x8.isIllegal() ) + return put( (x1,x2,x3,x4,x5,x6,x7) ); + return put( (x1,x2,x3,x4,x5,x6,x7,x8) ); +} + +safe read(const safe& x1) { + value result; + safecall_1(&Zread, result, x1); + return result; +} + +safe reads(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zreads, result, x1, x2); + return result; +} + +safe real(const safe& x1) { + value result; + safecall_1(&Zreal, result, x1); + return result; +} + +safe remove(const safe& x1) { + value result; + safecall_1(&Zremove, result, x1); + return result; +} + +safe rename(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zrename, result, x1, x2); + return result; +} + +safe repl(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zrepl, result, x1, x2); + return result; +} + +safe reverse(const safe& x1) { + value result; + safecall_1(&Zreverse, result, x1); + return result; +} + +safe right(const safe& x1, const safe& x2, const safe& x3) { + value result; + safecall_3(&Zright, result, x1, x2, x3); + return result; +} + +safe rtod(const safe& x1) { + value result; + safecall_1(&Zrtod, result, x1); + return result; +} + +safe runerr(const safe& x1, const safe& x2) { + value result; + safecall_v2(&Zrunerr, result, x1, x2); + return result; +} + +safe runerr(const safe& x1) { + value result; + safecall_v1(&Zrunerr, result, x1); + return result; +} + +safe seek(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zseek, result, x1, x2); + return result; +} + +safe serial(const safe& x1) { + value result; + safecall_1(&Zserial, result, x1); + return result; +} + +safe set(const safe& x1) { + value result; + safecall_1(&Zset, result, x1); + return result; +} + +safe sin(const safe& x1) { + value result; + safecall_1(&Zsin, result, x1); + return result; +} + +safe sort(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zsort, result, x1, x2); + return result; +} + +safe sortf(const safe& x1, const safe& x2) { + value result; + safecall_2(&Zsortf, result, x1, x2); + return result; +} + +safe sqrt(const safe& x1) { + value result; + safecall_1(&Zsqrt, result, x1); + return result; +} + +safe stop() { + safe result, nullarg; + safecall_vbl(&Zstop, result, nullarg); + return result; +} + +safe stop(const variadic& x1) { + safe result; + safecall_vbl(&Zstop, result, x1); + return result; +} + +safe stop( const safe& x1, const safe& x2, + const safe& x3, const safe& x4, + const safe& x5, const safe& x6, + const safe& x7, const safe& x8 ) { + if( x3.isIllegal() ) + return stop( (x1,x2) ); + if( x4.isIllegal() ) + return stop( (x1,x2,x3) ); + if( x5.isIllegal() ) + return stop( (x1,x2,x3,x4) ); + if( x6.isIllegal() ) + return stop( (x1,x2,x3,x4,x5) ); + if( x7.isIllegal() ) + return stop( (x1,x2,x3,x4,x5,x6) ); + if( x8.isIllegal() ) + return stop( (x1,x2,x3,x4,x5,x6,x7) ); + return stop( (x1,x2,x3,x4,x5,x6,x7,x8) ); +} + +safe string(const safe& x1) { + value result; + safecall_1(&Zstring, result, x1); + return result; +} + +safe system(const safe& x1) { + value result; + safecall_1(&Zsystem, result, x1); + return result; +} + +safe table(const safe& x1) { + value result; + safecall_1(&Ztable, result, x1); + return result; +} + +safe tan(const safe& x1) { + value result; + safecall_1(&Ztan, result, x1); + return result; +} + +safe trim(const safe& x1, const safe& x2) { + value result; + safecall_2(&Ztrim, result, x1, x2); + return result; +} + +safe type(const safe& x1) { + value result; + safecall_1(&Ztype, result, x1); + return result; +} + +safe variable(const safe& x1) { + value result; + safecall_1(&Zvariable, result, x1); + return result; +} + +safe where(const safe& x1) { + value result; + safecall_1(&Zwhere, result, x1); + return result; +} + +safe write() { + safe result, nullarg; + safecall_vbl(&Zwrite, result, nullarg); + return result; +} + +safe write(const variadic& x1) { + safe result; + safecall_vbl(&Zwrite, result, x1); + return result; +} + +safe write( const safe& x1, const safe& x2, + const safe& x3, const safe& x4, + const safe& x5, const safe& x6, + const safe& x7, const safe& x8 ) { + if( x3.isIllegal() ) + return write( (x1,x2) ); + if( x4.isIllegal() ) + return write( (x1,x2,x3) ); + if( x5.isIllegal() ) + return write( (x1,x2,x3,x4) ); + if( x6.isIllegal() ) + return write( (x1,x2,x3,x4,x5) ); + if( x7.isIllegal() ) + return write( (x1,x2,x3,x4,x5,x6) ); + if( x8.isIllegal() ) + return write( (x1,x2,x3,x4,x5,x6,x7) ); + return write( (x1,x2,x3,x4,x5,x6,x7,x8) ); +} + +safe writes(const variadic& x1) { + safe result; + safecall_vbl(&Zwrites, result, x1); + return result; +} + +safe writes( const safe& x1, const safe& x2, + const safe& x3, const safe& x4, + const safe& x5, const safe& x6, + const safe& x7, const safe& x8 ) { + if( x3.isIllegal() ) + return writes( (x1,x2) ); + if( x4.isIllegal() ) + return writes( (x1,x2,x3) ); + if( x5.isIllegal() ) + return writes( (x1,x2,x3,x4) ); + if( x6.isIllegal() ) + return writes( (x1,x2,x3,x4,x5) ); + if( x7.isIllegal() ) + return writes( (x1,x2,x3,x4,x5,x6) ); + if( x8.isIllegal() ) + return writes( (x1,x2,x3,x4,x5,x6,x7) ); + return writes( (x1,x2,x3,x4,x5,x6,x7,x8) ); +} + +//generative functions crippled to return a single value follow + +safe any(const safe& x1, const safe& x2=nullvalue, const safe& x3=nullvalue, const safe& x4=nullvalue) { + value result; + safecall_4(&Z_any, result, x1, x2, x3, x4); + return result; +} + +safe many(const safe& x1, const safe& x2=nullvalue, const safe& x3=nullvalue, const safe& x4=nullvalue) { + value result; + safecall_4(&Z_many, result, x1, x2, x3, x4); + return result; +} + +safe upto(const safe& x1, const safe& x2=nullvalue, const safe& x3=nullvalue, const safe& x4=nullvalue) { + value result; + safecall_4(&Z_upto, result, x1, x2, x3, x4); + return result; +} + +safe find(const safe& x1, const safe& x2=nullvalue, const safe& x3=nullvalue, const safe& x4=nullvalue) { + value result; + safecall_4(&Z_find, result, x1, x2, x3, x4); + return result; +} + +safe match(const safe& x1, const safe& x2=nullvalue, const safe& x3=nullvalue, const safe& x4=nullvalue) { + value result; + safecall_4(&Z_match, result, x1, x2, x3, x4); + return result; +} + +safe bal(const safe& x1, const safe& x2=nullvalue, const safe& x3=nullvalue, const safe& x4=nullvalue, const safe& x5=nullvalue, const safe& x6=nullvalue) { + value result; + safecall_6(&Z_bal, result, x1, x2, x3, x4, x5, x6); + return result; +} + +safe move(const safe& x1) { + value result; + safecall_1(&Z_move, result, x1); + return result; +} + +safe tab(const safe& x1) { + value result; + safecall_1(&Z_tab, result, x1); + return result; +} + +}; //namespace Icon + +/* + * Useful functions + */ + +//pass this on to external libraries, so they don't have to link against iconx (cygwin) +void syserror(const char* s) { syserr((char *)s); } + +value IconFile(FILE* fd, int status, char* fname) { + value answer, filename(NewString, fname); + answer.dword = D_File; + answer.vword = (long)alcfile(fd, status, &filename); + return answer; +} + +//large integer related and base64 related functions follow + +struct bignum { //after b_bignum in rstructs.h + long title; + long blksize; + long msd, lsd; + int sign; + unsigned int digit[1]; +}; + +//Endian/wordsize nonsense follows, to help get at bytes in the digits of Icon BigIntegers + +//repair moves the non-zero bytes we care about in a DIGIT (see rlrgint.r) +//that are in the least significant half of the bytes of a uint +//into the left hand end (in RAM) of the unint in big endian order + +//for solaris that does not define this macro +#ifndef BYTE_ORDER +#define BYTE_ORDER 4321 +#endif + +#if BYTE_ORDER==1234 || BYTE_ORDER==4321 +const int DIGITBYTES=2; + +#if BYTE_ORDER==1234 +inline unsigned int repair(unsigned int x) { + return (x & 0x0000FF00) >> 8 | (x & 0x000000FF) << 8; +} +inline long bigendian(long n) { + n = (n & 0xFFFF0000) >> 16 | (n & 0x0000FFFF) << 16; + return (n & 0xFF00FF00) >> 8 | (n & 0x00FF00FF) << 8; +} +#endif + +#if BYTE_ORDER==4321 +inline unsigned int repair(unsigned int x) { + return x << 2; +} +inline long bigendian(long n) { + return n; +} +#endif + +#endif + +#if BYTE_ORDER==12345678 || BYTE_ORDER==87654321 +const int DIGITBYTES=4; + +#if BYTE_ORDER==12345678 +inline unsigned int repair(unsigned int x) { + x = (x & 0x00000000FFFF0000) >> 16 | (x & 0x000000000000FFFF) << 16; + return (x & 0x00000000FF00FF00) >> 8 | (x & 0x0000000000FF00FF) << 8; +} +inline long bigendian(long n) { + n = (n & 0xFFFFFFFF00000000) >> 32 | (n & 0x00000000FFFFFFFF) << 32; + n = (n & 0xFFFF0000FFFF0000) >> 16 | (n & 0x0000FFFF0000FFFF) << 16; + return (n & 0xFF00FF00FF00FF00) >> 8 | (n & 0x00FF00FF00FF00FF) << 8; +} +#endif + +#if BYTE_ORDER==87654321 +inline unsigned int repair(unsigned int x) { + return x << 4; +} +inline long bigendian(long n) { + return n; +} +#endif + +#endif + +value integertobytes(value bigint){ //get the bytes of an Icon long integer as an Icon string (ignore sign) + safe n(bigint); + if( n == 0 ) return nullchar; + switch( bigint.type() ) { + case Integer: { + long x = bigint; + x = bigendian(x); + char *sbuf = (char *)&x; + int len = sizeof(long); + while( !*sbuf ) { //skip leading zeros in base 256 + ++sbuf; + --len; + } + return value(sbuf, len); + break; + } + case BigInteger: { + bignum *bp = ((bignum*)(bigint.vword)); + unsigned int current; + long pos = 0, len = (bp->lsd - bp->msd + 1) * DIGITBYTES; + char *source, *buf = new char[len], *sbuf; + sbuf = buf; + for(long i = bp->msd; i <= bp->lsd; ++i) { + current = repair(bp->digit[i]); + source = (char *)¤t; + for(int b=0; b < DIGITBYTES; ++b) + sbuf[pos++] = source[b]; + } + while( !*sbuf ) { //skip leading zeros in base 256 + ++sbuf; + --len; + } + value bytestring(sbuf, len); + delete[] buf; + return bytestring; + } + default: + return nullvalue; + } +} + +value bytestointeger(value bytestring){ //get the bytes of a new Icon long integer from an Icon string + if( bytestring.type() != String ) return nullvalue; + while( *(char*)bytestring.vword == 0 && bytestring.dword != 0 ) { //skip leading zeros + --bytestring.dword; + ++bytestring.vword; + } + safe s(bytestring); + long size = value(*s); + if( size == 0 ) return 0; + unsigned char *bytes = (unsigned char *)((char*)bytestring); + long n = 0; + if( size < sizeof(long) || //doesn't overflow a signed long + (size == sizeof(long) && ( bytes[0] <= 0x7F )) ) { + for(int i = 0; i < size; ++i) + n = (n << 8) + bytes[i]; + return n; + } + static const int RATIO = sizeof(unsigned int)/2; + long len = (size + RATIO - 1)/RATIO; //number of digits + bignum *bp = (bignum *)alcbignum(len); + bytestring = s; //in case the allocation caused a garbage collection + bytes = (unsigned char *)((char*)bytestring); + long pos = 0; + const int FIRST = len*RATIO==size ? RATIO : len*RATIO-size; //bytes in the first digit + n = 0; + for(int p=0; p < FIRST; ++p) + n = (n << 8) + bytes[pos++]; + bp->digit[0] = n; + for(long i = bp->msd + 1; i <= bp->lsd; ++i) { + n = 0; + for(int p=0; p < RATIO; ++p) + n = (n << 8) + bytes[pos++]; + bp->digit[i] = n; + } + value answer; + answer.dword = D_Lrgint; + answer.vword = (long)bp; + return answer; +} + +//base64 utilities +typedef unsigned char uchar; +static char chr[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"; + +//3 bytes -> four base64 chars +inline void threetofour(uchar *three, uchar* four) { + unsigned long n = three[0]; + n = (((n << 8) + three[1]) << 8) + three[2]; + four[3] = chr[n & 0x3F]; + n = n >> 6; + four[2] = chr[n & 0x3F]; + n = n >> 6; + four[1] = chr[n & 0x3F]; + n = n >> 6; + four[0] = chr[n & 0x3F]; +} + +//two trailing bytes -> four base64 chars +inline void twotofour(uchar *three, uchar* four) { + unsigned long n = three[0]; + n = ((n << 8) + three[1]) << 2; + four[3] = '='; + four[2] = chr[n & 0x3F]; + n = n >> 6; + four[1] = chr[n & 0x3F]; + n = n >> 6; + four[0] = chr[n & 0x3F]; +} + +//one trailing byte -> four base64 chars +inline void onetofour(uchar *three, uchar* four) { + unsigned long n = three[0]; + n = n << 4; + four[3] = four[2] = '='; + four[1] = chr[n & 0x3F]; + n = n >> 6; + four[0] = chr[n & 0x3F]; +} + +//convert to base64, return the length of the encoded string +inline long b64(char *in, long len, char* out) { + char *start = out; + long num = len/3; + int rem = len%3; + for(long i = 0; i < num; ++i) { + threetofour((uchar*)in, (uchar*)out); + in += 3; + out += 4; + } + switch( rem ) { + case 1: + onetofour((uchar*)in, (uchar*)out); + out += 4; + break; + case 2: + twotofour((uchar*)in, (uchar*)out); + out += 4; + break; + } + return out - start; +} + +//constant denoting an invalid character in a putative base64 encoding +static const int NONSENSE = -1; + +//convert a base64 char into its corresponding 6 bits +inline int undo(uchar ch) { + switch( ch ) { + default: return NONSENSE; + case 'A': return 0; case 'B': return 1; case 'C': return 2; case 'D': return 3; + case 'E': return 4; case 'F': return 5; case 'G': return 6; case 'H': return 7; + case 'I': return 8; case 'J': return 9; case 'K': return 10; case 'L': return 11; + case 'M': return 12; case 'N': return 13; case 'O': return 14; case 'P': return 15; + case 'Q': return 16; case 'R': return 17; case 'S': return 18; case 'T': return 19; + case 'U': return 20; case 'V': return 21; case 'W': return 22; case 'X': return 23; + case 'Y': return 24; case 'Z': return 25; case 'a': return 26; case 'b': return 27; + case 'c': return 28; case 'd': return 29; case 'e': return 30; case 'f': return 31; + case 'g': return 32; case 'h': return 33; case 'i': return 34; case 'j': return 35; + case 'k': return 36; case 'l': return 37; case 'm': return 38; case 'n': return 39; + case 'o': return 40; case 'p': return 41; case 'q': return 42; case 'r': return 43; + case 's': return 44; case 't': return 45; case 'u': return 46; case 'v': return 47; + case 'w': return 48; case 'x': return 49; case 'y': return 50; case 'z': return 51; + case '0': return 52; case '1': return 53; case '2': return 54; case '3': return 55; + case '4': return 56; case '5': return 57; case '6': return 58; case '7': return 59; + case '8': return 60; case '9': return 61; case '+': return 62; case '/': return 63; + } +} + +//four base64 chars -> three bytes +inline long unfour(uchar* four, uchar* three) { + int ch; + if( (ch = undo(four[0])) == NONSENSE ) return NONSENSE; + long n = ch; + if( (ch = undo(four[1])) == NONSENSE ) return NONSENSE; + n = (n << 6) + ch; + if( (ch = undo(four[2])) == NONSENSE ) return NONSENSE; + n = (n << 6) + ch; + if( (ch = undo(four[3])) == NONSENSE ) return NONSENSE; + n = (n << 6) + ch; + three[2] = n & 0xFF; + n = n >> 8; + three[1] = n & 0xFF; + three[0] = n >> 8; +} + +//decode a base64 string; return NONSENSE if anything doesn't make strict sense +inline long unb64(char* in, long len, char* out) { + char* start = out; + if( len == 0 ) return 0; + if( len%4 != 0 ) return NONSENSE; + int last = 0; + if( in[len-1] == '=' ) { + last = 1; + if( in[len-2] == '=' ) last = 2; + } + if( last ) len -= 4; + + for(long i = 0; i < len/4; ++i) { + if( unfour((uchar*)in, (uchar*)out) == NONSENSE ) + return NONSENSE; + in += 4; + out += 3; + } + long n; + int ch0, ch1, ch2; + switch( last ) { + case 1: + if( (ch0 = undo((uchar)in[0])) == NONSENSE ) + return NONSENSE; + if( (ch1 = undo((uchar)in[1])) == NONSENSE ) + return NONSENSE; + if( (ch2 = undo((uchar)in[2])) == NONSENSE ) + return NONSENSE; + n = ((((ch0 << 6) + ch1) << 6) + ch2) >> 2; + out[1] = n & 0xFF; + out[0] = n >> 8; + out += 2; + break; + case 2: + if( (ch0 = undo((uchar)in[0])) == NONSENSE ) + return NONSENSE; + if( (ch1 = undo((uchar)in[1])) == NONSENSE ) + return NONSENSE; + n = (ch0 << 6) + ch1; + out[0] = n >> 4; + out += 1; + break; + } + return out - start; +} + +//convert string or integer to base64 string +value base64(value x) { + switch( x.type() ) { + default: + return nullvalue; + case Integer: + case BigInteger: + x = integertobytes(x); + case String: { + char* enc = new char[4*x.dword/3+8]; //safety first + long len = b64((char*)x.vword, x.dword, enc); + value answer(enc, len); + delete[] enc; + return answer; + } + } +} + +//decode base64 encoding of a string +value base64tostring(value s) { + if( s.type() != String || + s.dword % 4 != 0) + return nullvalue; + if( s.dword == 0 ) return nullstring; + long len; + char* dec = new char[3 * s.dword/4]; //safety first + if( (len = unb64((char*)s.vword, s.dword, dec)) == NONSENSE ) { + delete[] dec; + return nullvalue; + } + value answer(dec, len); + delete[] dec; + return answer; +} + +//decode base64 encoding of an integer +value base64tointeger(value s) { + return bytestointeger(base64tostring(s)); +} + + + +/* + * 1. Calling Icon from C++ (mostly in iloadgpx.cpp and iloadnogpx.cpp) + * 2. loadfuncpp itself + * 3. binding records to procedure blocks + */ + +namespace ifload { +//remove interference with icon/src/h/rt.h +#undef D_Null +#undef D_Integer +#undef D_Lrgint +#undef D_Real +#undef D_File +#undef D_Proc +#undef D_External +#undef Fs_Read +#undef Fs_Write +#undef F_Nqual +#undef F_Var + +#include "xfload.cpp" //inline linkage --- three argument raw loadfunc +}; //end namespace ifload; put things that need Icon's rt.h included by xfload.cpp below here + +//call to the modified loadfunc in xfload.cpp +static int rawloadfuncpp(value argv[]) { + return ifload::Z_loadfunc((ifload::dptr)argv); +} + + +//get the record from the bottom of an extended procedure block +//(procedure bound to record) obtained from the procedure that +//called our procedure self(). Fail if no record is bound. +extern "C" int getbinding(value* argv) { + value* pp = (value*)((ifload::pfp)->pf_argp); //get saved procedure + if( pp==0 ) syserror("loadfuncpp bug: attempt to find caller of self() failed!"); + proc_block* pbp = *pp; + int nsafe = pbp->ndynam + pbp->nparam; + if( (pbp->blksize) - sizeof(proc_block) == (nsafe-1) * sizeof(value) ) { + argv[0] = nullvalue; + return FAILED; + } + argv[0] = pbp->lnames[nsafe]; + return SUCCEEDED; +} + + +#if __CYGWIN__ //cygwin linkage problem workaround +namespace icall { + using namespace ifload; + //icall assigned from whichever of iloadgpx.so and iloadnogpx.so is loaded, on load thereof +extern "C" { + typedef int icallfunction(dptr procptr, dptr arglistptr, dptr result); +}; + icallfunction *icall2; +}; + +value Value::call(const value& proc, const value& arglist) { + value result; + (*(icall::icall2))( (icall::dptr)(&proc), (icall::dptr)(&arglist), (icall::dptr)(&result) ); + return result; +} +#endif //cygwin linkage problem workaround + diff --git a/ipl/packs/loadfuncpp/iload.h b/ipl/packs/loadfuncpp/iload.h new file mode 100644 index 0000000..7b9c693 --- /dev/null +++ b/ipl/packs/loadfuncpp/iload.h @@ -0,0 +1,342 @@ + +/* C++ support for easy extensions to icon via loadfunc, + * without garbage collection difficulties. + * Include loadfuncpp.h and link dynamically to + * iload.cpp, which contains the necessary glue. + * See iexample.cpp for typical use. + * Carl Sturtivant, 2008/3/17 + */ + + +#include <climits> +#include <cstdlib> + +#if LONG_MAX == 2147483647L //32 bit icon implementation word +#define D_Null 0xA0000000 +#define D_Integer 0xA0000001 +#define D_Lrgint 0xB0000002 +#define D_Real 0xB0000003 +#define D_File 0xB0000005 +#define D_Proc 0xB0000006 +#define D_External 0xB0000013 +#define D_Illegal 0xA0000063 +#define F_Nqual 0x80000000 +#define F_Var 0x40000000 +#else //64 bit icon implementation word +#define D_Null 0xA000000000000000 +#define D_Integer 0xA000000000000001 +#define D_Lrgint 0xB000000000000002 +#define D_Real 0xB000000000000003 +#define D_File 0xB000000000000005 +#define D_Proc 0xB000000000000006 +#define D_External 0xB000000000000013 +#define D_Illegal 0xA000000000000063 +#define F_Nqual 0x8000000000000000 +#define F_Var 0x4000000000000000 +#endif + +#define T_Null 0 // null value +#define T_Integer 1 // integer +#define T_Lrgint 2 // long integer +#define T_Real 3 // real number +#define T_Cset 4 // cset +#define T_File 5 // file +#define T_Proc 6 // procedure +#define T_Record 7 // record +#define T_List 8 // list +#define T_Set 10 // set +#define T_Table 12 // table +#define T_Coexpr 18 // coexpression +#define T_External 19 // external value + +#define TypeMask 63 // type mask + +#define SUSPEND 1 // Call the interpreter suspending from a C function: G_Csusp + +extern "C" { //callbacks in iconx + +void deref(value*, value*); //dereference an icon 'variable' descriptor +char* alcstr(char*, int); //allocate an icon string by copying +char *alcreal(double); //allocate double by copying +char *alcbignum(long); //allocate Icon large integer block w/ given number of DIGITS +double getdbl(value*); //retrieve double +char* alcfile(FILE *fp, int stat, value *name); +int anycmp(const value*, const value*); //comparator used when sorting in Icon +//alcexternal in iconx for Icon 9.5 and above +external* alcexternal(long nbytes, external_ftable* ftable, external* ep); + +void syserr(char*); //fatally terminate Icon-style with error message + +int interp(int fsig, value *cargp); //the Icon interpreter, called recursively when suspending + + +//the prototypes of all icon functions and operators in iconx needed to do the dirty work +iconfunc Oasgn; +iconfunc Osubsc; +iconfunc Osize; +iconfunc Oneg; +iconfunc Ocompl; +iconfunc Orefresh; +iconfunc Orandom; +iconfunc Oplus; +iconfunc Ominus; +iconfunc Omult; +iconfunc Odivide; +iconfunc Omod; +iconfunc Opowr; +iconfunc Ounion; +iconfunc Ointer; +iconfunc Odiff; +iconfunc Ocater; +iconfunc Olconcat; +iconfunc Osect; +iconfunc Oswap; + +iconfvbl Ollist; + +iconfunc Zloadfunc; +iconfunc Zproc; +iconfunc Zvariable; + +iconfunc Zlist; +iconfunc Zset; +iconfunc Ztable; + +iconfunc Zstring; +iconfunc Zcset; +iconfunc Zinteger; +iconfunc Zreal; +iconfunc Znumeric; + +iconfvbl Zput; +iconfvbl Zpush; + +iconfvbl Zrunerr; +iconfvbl Zwrites; +iconfunc Zimage; + +iconfunc Zabs; +iconfunc Zacos; +iconfunc Zargs; +iconfunc Zasin; +iconfunc Zatan; +iconfunc Zcenter; +iconfunc Zchar; +iconfunc Zchdir; +iconfunc Zclose; +iconfunc Zcollect; +iconfunc Zcopy; +iconfunc Zcos; +iconfunc Zdelay; +iconfunc Zdelete; +iconfunc Zdisplay; +iconfunc Zdtor; +iconfunc Zerrorclear; +iconfunc Zexit; +iconfunc Zexp; +iconfunc Zflush; +iconfunc Zget; +iconfunc Zgetch; +iconfunc Zgetche; +iconfunc Zgetenv; +iconfunc Ziand; +iconfunc Zicom; +iconfunc Zinsert; +iconfunc Zior; +iconfunc Zishift; +iconfunc Zixor; +iconfunc Zkbhit; +iconfunc Zleft; +iconfunc Zlog; +iconfunc Zmap; +iconfunc Zmember; +iconfunc Zname; +iconfunc Zopen; +iconfunc Zord; +iconfunc Zpop; +iconfunc Zpull; +iconfunc Zread; +iconfunc Zreads; +iconfunc Zremove; +iconfunc Zrename; +iconfunc Zrepl; +iconfunc Zreverse; +iconfunc Zright; +iconfunc Zrtod; +iconfunc Zseek; +iconfunc Zserial; +iconfunc Zsin; +iconfunc Zsort; +iconfunc Zsortf; +iconfunc Zsqrt; +iconfunc Zsystem; +iconfunc Ztan; +iconfunc Ztrim; +iconfunc Ztype; +iconfunc Zwhere; + +iconfvbl Zdetab; +iconfvbl Zentab; +iconfvbl Zpush; +iconfvbl Zput; +iconfvbl Zstop; +iconfvbl Zwrite; + +iconfunc Kallocated; +iconfunc Kascii; +iconfunc Kclock; +//iconfunc Kcol; +iconfunc Kcollections; +//iconfunc Kcolumn; +//iconfunc Kcontrol; +iconfunc Kcset; +iconfunc Kcurrent; +iconfunc Kdate; +iconfunc Kdateline; +iconfunc Kdigits; +iconfunc Kdump; +iconfunc Ke; +iconfunc Kerror; +iconfunc Kerrornumber; +iconfunc Kerrortext; +iconfunc Kerrorvalue; +iconfunc Kerrout; +//iconfunc Keventcode; +//iconfunc Keventsource; +//iconfunc Keventvalue; +iconfunc Kfail; +iconfunc Kfeatures; +iconfunc Kfile; +iconfunc Khost; +iconfunc Kinput; +//iconfunc Kinterval; +iconfunc Klcase; +//iconfunc Kldrag; +iconfunc Kletters; +iconfunc Klevel; +iconfunc Kline; +//iconfunc Klpress; +//iconfunc Klrelease; +iconfunc Kmain; +//iconfunc Kmdrag; +//iconfunc Kmeta; +//iconfunc Kmpress; +//iconfunc Kmrelease; +iconfunc Knull; +iconfunc Koutput; +iconfunc Kphi; +iconfunc Kpi; +iconfunc Kpos; +iconfunc Kprogname; +iconfunc Krandom; +//iconfunc Krdrag; +iconfunc Kregions; +iconfunc Kresize; +//iconfunc Krow; +//iconfunc Krpress; +//iconfunc Krrelease; +//iconfunc Kshift; +iconfunc Ksource; +iconfunc Kstorage; +iconfunc Ksubject; +iconfunc Ktime; +iconfunc Ktrace; +iconfunc Kucase; +iconfunc Kversion; +iconfunc Kwindow; +//iconfunc Kx; +//iconfunc Ky; + +} //end extern "C" + +struct proc_block { + long title; /* T_Proc */ + long blksize; /* size of block */ + iconfvbl *entryp; /* entry point for C routine */ + long nparam; /* number of parameters */ + long ndynam; /* number of dynamic locals */ + long nstatic; /* number of static locals */ + long fstatic; /* index (in global table) of first static */ + value pname; /* procedure name (string qualifier) */ + value lnames[1]; /* list of local names (qualifiers) */ + private: + inline void init(value procname) { + title = T_Proc; + blksize = sizeof(proc_block); + ndynam = -1; //treat as a built-in function + nstatic = 0; + fstatic = 0; + pname = procname; + lnames[0] = nullstring; + } + static long extra_bytes; + public: + proc_block(value procname, iconfvbl *function); + proc_block(value procname, iconfunc *function, int arity); + proc_block(value procname, iconfvbl *function, int arity); + proc_block(proc_block*); + static proc_block* bind(proc_block*, const value&); + static void* operator new(size_t); //allocated by iconx + static void operator delete(void*); //do nothing +}; + +struct coexp_block { + long title; + long size; + long id; + coexp_block* next; + void* es_pfp; + void* es_efp; + void* es_gfp; + safe_variable* es_tend; + value* es_argp; + //... +}; + +// name/proc-block table of built-in functions +struct pstrnm { char* pstrep; proc_block *pblock; }; +extern pstrnm pntab[]; //table of original procedure blocks (src/runtime/data.r) +extern int pnsize; //size of said table +extern "C" { +int dp_pnmcmp(struct pstrmn*, value*); //comparison function +char* qsearch(char*, char*, int, int, int (*)(struct pstrmn*, value*)); //search for a name +} + +inline int safecall_0(iconfunc*, value&); +inline int safecall_1(iconfunc*, value&, const value&); +inline int safecall_2(iconfunc*, value&, const value&, const value&); +inline int safecall_3(iconfunc*, value&, const value&, const value&, const value&); +inline int safecall_4(iconfunc*, value&, const value&, const value&, const value&, const value&); +inline int safecall_5(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&); +inline int safecall_6(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&, const value&); +inline int safecall_v0(iconfvbl*, value&); +inline int safecall_v1(iconfvbl*, value&, const value&); +inline int safecall_v2(iconfvbl*, value&, const value&, const value&); +inline int safecall_v3(iconfvbl*, value&, const value&, const value&, const value&); +inline int safecall_vbl(iconfvbl*,safe&, const variadic&); + +//iconx GC tend list +extern safe_variable* tend; +//our global GC tend list +extern safe_variable*& global_tend; + +extern value k_current, k_main; //descriptors for ¤t and &main + +//useful helper functions +namespace Value { + value list(value n = (long)0, value init = nullvalue); + value pair(value, value); + value set(value list=nullvalue); + void runerr(value i, value x = nullvalue); + value table(value init = nullvalue); + value variable(value name); + value proc(value name, value arity = nullvalue); + value libproc(value name, value arity = nullvalue); + value call(const value& proc, const value& arglist); + value create(const value&, const value&); // create x!y + value reduce(const value&, const value&, const value&, const value&); +}; //end namespace Value + +//raw call to the modified three argument loadfunc +static int rawloadfuncpp(value argv[]); + diff --git a/ipl/packs/loadfuncpp/iloadgpx.cpp b/ipl/packs/loadfuncpp/iloadgpx.cpp new file mode 100644 index 0000000..fa774f0 --- /dev/null +++ b/ipl/packs/loadfuncpp/iloadgpx.cpp @@ -0,0 +1,64 @@ + + +#include "loadfuncpp.h" +#include "iload.h" + +#define GPX 1 //enables polling for events when calling Icon from C++ + +namespace icall { +//remove interference with icon/src/h/rt.h +#undef D_Null +#undef D_Integer +#undef D_Lrgint +#undef D_Real +#undef D_File +#undef D_Proc +#undef D_External +#undef Fs_Read +#undef Fs_Write +#undef F_Nqual +#undef F_Var + +#include "xinterp.cpp" + +#ifdef __CYGWIN__ +extern "C" { + typedef int icallfunction(dptr procptr, dptr arglistptr, dptr result); +}; + extern icallfunction *icall2; +#endif //cywgin + +}; + +#ifdef __CYGWIN__ + +//linking constraints make us do our own linking +class linkicall { + public: + linkicall() { //assign our icall to a function pointer in iload.so + icall::icall2 = &(icall::icall); + } +}; +static linkicall load; + +#else //not cygwin +//call an Icon procedure that always returns a value and never suspends +value Value::call(const value& proc, const value& arglist) { + value result; + icall::icall( (icall::dptr)(&proc), (icall::dptr)(&arglist), (icall::dptr)(&result) ); + return result; +} + +#endif //not cywgin + +//succeed if graphics are present, fail otherwise +extern "C" int iconx_graphics(value argv[]) { + argv[0] = nullvalue; + return SUCCEEDED; +} + +//put Icon graphics keywords and functions here +//plus access to the event queue for new I/O events associated with sockets + + + diff --git a/ipl/packs/loadfuncpp/iloadnogpx.cpp b/ipl/packs/loadfuncpp/iloadnogpx.cpp new file mode 100644 index 0000000..de1f25f --- /dev/null +++ b/ipl/packs/loadfuncpp/iloadnogpx.cpp @@ -0,0 +1,63 @@ + + +#include "loadfuncpp.h" +#include "iload.h" + +#define GPX 0 //prevents polling for events when calling Icon from C++ + +namespace icall { +//remove interference with icon/src/h/rt.h +#undef D_Null +#undef D_Integer +#undef D_Lrgint +#undef D_Real +#undef D_File +#undef D_Proc +#undef D_External +#undef Fs_Read +#undef Fs_Write +#undef F_Nqual +#undef F_Var + +#include "xinterp.cpp" + +#ifdef __CYGWIN__ +extern "C" { + typedef int icallfunction(dptr procptr, dptr arglistptr, dptr result); +}; + extern icallfunction *icall2; +#endif //cywgin + +}; + +#ifdef __CYGWIN__ + +//linking constraints make us do our own linking +class linkicall { + public: + linkicall() { //assign our icall to a function pointer in iload.so + icall::icall2 = &(icall::icall); + } +}; +static linkicall load; + +#else //not cygwin + +//call an Icon procedure that always returns a value and never suspends +value Value::call(const value& proc, const value& arglist) { + value result; + icall::icall( (icall::dptr)(&proc), (icall::dptr)(&arglist), (icall::dptr)(&result) ); + return result; +} + +#endif //not cywgin + +//succeed if graphics are present, fail otherwise +extern "C" int iconx_graphics(value argv[]) { + return FAILED; +} + + + + + diff --git a/ipl/packs/loadfuncpp/loadfuncpp.h b/ipl/packs/loadfuncpp/loadfuncpp.h new file mode 100644 index 0000000..5704f60 --- /dev/null +++ b/ipl/packs/loadfuncpp/loadfuncpp.h @@ -0,0 +1,481 @@ + +/* C++ support for easy extensions to icon via loadfunc, + * without garbage collection difficulties. + * Include this and link to iload.cpp which + * contains the necessary glue. + * See iexample.cpp for typical use. + * Carl Sturtivant, 2008/3/17 + */ + +#include<new> +#include<cstdio> + +enum kind { Null, Integer, BigInteger, Real, Cset, File, Procedure, Record, List, + Set=10, Table=12, String, Constructor, Coexpression=18, External, Variable }; + +enum special_value { NullString, StringLiteral, NewString, NullChar, Illegal }; + +enum { + SUCCEEDED = 7, // Icon function call returned: A_Continue + FAILED = 1 // Icon function call failed: A_Resume +}; + +class value; //Icon value (descriptor) +class safe; //for garbage-collection-safe Icon valued C++ variables and parameters of all kinds +class keyword; //Icon keyword represented as an object with unary & +class variadic; //for garbage-collection-safe variadic function argument lists +class proc_block; //block specifying a procedure to iconx +class external_block; //block specifying an external value to iconx +class external_ftable; //function pointers specifying external value behavior to iconx +class external; //C++ Object specifying an external value + +typedef int iconfunc(value argv[]); //type of icon built in functions or operators with a fixed number of arguments +typedef int iconfvbl(int argc, value argv[]); //type of icon built in functions with a variable number of arguments + +extern const value nullvalue; //for default arguments +extern const value nullstring; +extern const value nullchar; +extern const value illegal; //for unwanted trailing arguments +extern void syserror(const char*); //fatal termination Icon-style with error message +#define Fs_Read 0001 // file open for reading +#define Fs_Write 0002 // file open for writing +extern value IconFile(int fd, int status, char* fname); //make an Icon file descriptor +extern value integertobytes(value); //get the bytes of an Icon long integer as an Icon string (ignore sign) +extern value bytestointeger(value); //get the bytes of a new Icon long integer from an Icon string +extern value base64(value); //convert string or integer to base64 encoding (string) +extern value base64tointeger(value); //decode base64 string to integer +extern value base64tostring(value); //decode base64 string to string + +namespace Icon { +//all keywords excepting &fail, &cset (avoiding a name collision with function cset) +extern keyword allocated; +extern keyword ascii; +extern keyword clock; +extern keyword collections; +extern keyword current; +extern keyword date; +extern keyword dateline; +extern keyword digits; +extern keyword dump; +extern keyword e; +extern keyword error; +extern keyword errornumber; +extern keyword errortext; +extern keyword errorvalue; +extern keyword errout; +extern keyword features; +extern keyword file; +extern keyword host; +extern keyword input; +extern keyword lcase; +extern keyword letters; +extern keyword level; +extern keyword line; +extern keyword main; +extern keyword null; +extern keyword output; +extern keyword phi; +extern keyword pi; +extern keyword pos; +extern keyword progname; +extern keyword random; +extern keyword regions; +extern keyword source; +extern keyword storage; +extern keyword subject; +extern keyword time; +extern keyword trace; +extern keyword ucase; +extern keyword version; +}; //namespace Icon + +static void initialize_keywords(); + +class keyword { //objects representing Icon keywords + friend void initialize_keywords(); + iconfunc* f; + public: + safe operator&(); //get the keyword's value (could be an Icon 'variable') +}; + + +class value { //a descriptor with class +//data members modelled after 'typedef struct { word dword, vword; } descriptor;' from icall.h + private: + long dword; + long vword; + public: + friend class safe; + friend value IconFile(FILE* fd, int status, char* fname); + friend value integertobytes(value); + friend value bytestointeger(value); + friend value base64(value); + friend value base64tointeger(value); + friend value base64tostring(value); + value(); //&null + value(special_value, const char* text = ""); + value(int argc, value* argv); //makes a list of parameters passed in from Icon + value(int); + value(long); + value(float); + value(double); + value(char*); + value(const char*); + value(const char*, long); + value(proc_block&); + value(proc_block*); + value(external*); + operator int(); + operator long(); + operator float(); + operator double(); + operator char*(); + operator external*(); + operator proc_block*() const; + bool operator==(const value&) const; + value& dereference(); + value intify(); + bool isNull(); + bool notNull(); + bool isExternal(const value&); + value size() const; + kind type(); + bool toString(); //attempted conversion in place + bool toCset(); + bool toInteger(); + bool toReal(); + bool toNumeric(); + value subscript(const value&) const; //produces an Icon 'variable' + value& assign(const value&); //dereferences Icon style + value put(value x = nullvalue); + value push(value x = nullvalue); + void dump() const; + void printimage() const; + int compare(const value&) const; //comparator-style result: used for Icon sorting + value negative() const; // -x + value complement() const; // ~x + value refreshed() const; // ^x + value random() const; // ?x + value plus(const value&) const; + value minus(const value&) const; + value multiply(const value&) const; + value divide(const value&) const; + value remainder(const value&) const; + value power(const value&) const; + value union_(const value&) const; // x ++ y + value intersection(const value&) const; // x ** y + value difference(const value&) const; // x -- y + value concatenate(const value&) const; // x || y + value listconcatenate(const value&) const;// x ||| y + value slice(const value&, const value&) const; // x[y:z] + value& swap(value&); // x :=: y + value activate(const value& y = nullvalue) const; // y @ x ('*this' is activated) + value apply(const value&) const; // x!y (must return, not fail or suspend) +}; //class value + + +class generator { +//class to inherit from for defining loadable functions that are generators + public: + int generate(value argv[]); //call to suspend everything produced by next() + protected: //override these, and write a constructor + virtual bool hasNext(); + virtual value giveNext(); +}; //class generator + + +class iterate { +//class to inherit from for iterating over f!arg or !x + public: + void every(const value& g, const value& arg); //perform the iteration over g!arg + void bang(const value& x); //perform the iteration over !x + //override these, write a constructor and the means of recovering the answer + virtual bool wantNext(const value& x); + virtual void takeNext(const value& x); +}; + + + +class safe_variable { +//data members modelled after 'struct tend_desc' from rstructs.h + friend class value; + friend inline int safecall_0(iconfunc*, value&); + friend inline int safecall_1(iconfunc*, value&, const value&); + friend inline int safecall_2(iconfunc*, value&, const value&, const value&); + friend inline int safecall_3(iconfunc*, value&, const value&, const value&, const value&); + friend inline int safecall_4(iconfunc*, value&, const value&, const value&, const value&, const value&); + friend inline int safecall_5(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&); + friend inline int safecall_6(iconfunc*, value&, const value&, const value&, const value&, const value&, const value&, const value&); + friend inline int safecall_v0(iconfvbl*, value&); + friend inline int safecall_v1(iconfvbl*, value&, const value&); + friend inline int safecall_v2(iconfvbl*, value&, const value&, const value&); + friend inline int safecall_v3(iconfvbl*, value&, const value&, const value&, const value&); + friend inline int safecall_vbl(iconfvbl*,safe&, const variadic&); + protected: + safe_variable *previous; + int num; + value val; + safe_variable(); + safe_variable(int); + safe_variable(long); + safe_variable(double); + safe_variable(value); + safe_variable(proc_block&); + safe_variable(proc_block*); + safe_variable(int, value*); + inline void push(safe_variable*& tendlist, int numvalues=1); + inline void pop(safe_variable*& tendlist); +}; //class safe_variable + + +class variadic: public safe_variable { + public: + variadic(int); + variadic(long); + variadic(float); + variadic(double); + variadic(char*); + variadic(value); + variadic(const safe&); + variadic(const safe&, const safe&); + variadic& operator,(const safe&); + operator value(); + ~variadic(); +}; //class variadic + + +class external_block { +//modelled on 'struct b_external' in icon/src/h/rstructs.h + friend class external; + friend class value; + static long extra_bytes; //silent extra parameter to new + long title; + long blksize; + long id; + external_ftable* funcs; + external* val; + static void* operator new(size_t); //allocated by iconx + static void operator delete(void*); //do nothing + external_block(); +}; + +class external { + friend class value; + static external_block* blockptr; //silent extra result of new + protected: + long id; + public: + static void* operator new(size_t); //allocated by new external_block() + static void operator delete(void*); //do nothing + external(); + virtual ~external() {} //root class + virtual long compare(external*); + virtual value name(); + virtual external* copy(); + virtual value image(); +}; + + +class safe: public safe_variable { +//use for a garbage collection safe icon valued safe C++ variable + friend class variadic; + friend class global; + public: + safe(); //&null + safe(const safe&); + safe(int); + safe(long); + safe(float); + safe(double); + safe(char*); + safe(const value&); + safe(const variadic&); + safe(proc_block&); + safe(proc_block*); + safe(int, value*); //from parameters sent in from Icon + ~safe(); + safe& operator=(const safe&); + //augmenting assignments here + safe& operator+=(const safe&); + safe& operator-=(const safe&); + safe& operator*=(const safe&); + safe& operator/=(const safe&); + safe& operator%=(const safe&); + safe& operator^=(const safe&); + safe& operator&=(const safe&); + safe& operator|=(const safe&); + // ++ and -- here + safe& operator++(); + safe& operator--(); + safe operator++(int); + safe operator--(int); + //conversion to value + operator value() const; + //procedure call + safe operator()(); + safe operator()(const safe&); + safe operator()(const safe& x1, const safe& x2, + const safe& x3 = illegal, const safe& x4 = illegal, + const safe& x5 = illegal, const safe& x6 = illegal, + const safe& x7 = illegal, const safe& x8 = illegal); + safe operator[](const safe&); + + friend safe operator*(const safe&); //size + friend safe operator-(const safe&); + friend safe operator~(const safe&); //set complement + friend safe operator+(const safe&, const safe&); + friend safe operator-(const safe&, const safe&); + friend safe operator*(const safe&, const safe&); + friend safe operator/(const safe&, const safe&); + friend safe operator%(const safe&, const safe&); + friend safe operator^(const safe&, const safe&); //exponentiation + friend safe operator|(const safe&, const safe&); //union + friend safe operator&(const safe&, const safe&); //intersection + friend safe operator&&(const safe&, const safe&); //set or cset difference + friend safe operator||(const safe&, const safe&); //string concatenation + friend bool operator<(const safe&, const safe&); + friend bool operator>(const safe&, const safe&); + friend bool operator<=(const safe&, const safe&); + friend bool operator>=(const safe&, const safe&); + friend bool operator==(const safe&, const safe&); + friend bool operator!=(const safe&, const safe&); + friend variadic operator,(const safe&, const safe&); //variadic argument list construction + + safe slice(const safe&, const safe&); // x[y:z] + safe apply(const safe&); // x ! y + safe listcat(const safe&); // x ||| y + safe& swap(safe&); // x :=: y + safe create(); // create !x + safe create(const safe&); // create x!y + safe activate(const safe& y = nullvalue); // y@x + safe refresh(); // ^x + safe random(); // ?x + safe dereference(); // .x + bool isIllegal() const; //is an illegal value used for trailing arguments +}; //class safe + + +//Icon built-in functions +namespace Icon { + safe abs(const safe&); + safe acos(const safe&); + safe args(const safe&); + safe asin(const safe&); + safe atan(const safe&, const safe&); + safe center(const safe&, const safe&, const safe&); + safe char_(const safe&); + safe chdir(const safe&); + safe close(const safe&); + safe collect(); + safe copy(const safe&); + safe cos(const safe&); + safe cset(const safe&); + safe delay(const safe&); + safe delete_(const safe&, const safe&); + safe detab(const variadic&); + safe detab( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe display(const safe&, const safe&); + safe dtor(const safe&); + safe entab(const variadic&); + safe entab( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe errorclear(); + safe exit(const safe&); + safe exp(const safe&); + safe flush(const safe&); + safe function(); //generative: returns a list + safe get(const safe&); + safe getch(); + safe getche(); + safe getenv(const safe&); + safe iand(const safe&, const safe&); + safe icom(const safe&); + safe image(const safe&); + safe insert(const safe&, const safe&, const safe&); + safe integer(const safe&); + safe ior(const safe&, const safe&); + safe ishift(const safe&, const safe&); + safe ixor(const safe&, const safe&); + safe kbhit(); + safe left(const safe&, const safe&, const safe&); + safe list(const safe&, const safe&); + safe loadfunc(const safe&, const safe&); + safe log(const safe&); + safe map(const safe&, const safe&, const safe&); + safe member(const safe&, const safe&); + safe name(const safe&); + safe numeric(const safe&); + safe open(const safe&, const safe&); + safe ord(const safe&); + safe pop(const safe&); + safe proc(const safe&, const safe&); + safe pull(const safe&); + safe push(const variadic&); + safe push( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe put(const variadic&); + safe put( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe read(const safe&); + safe reads(const safe&, const safe&); + safe real(const safe&); + safe remove(const safe&); + safe rename(const safe&, const safe&); + safe repl(const safe&, const safe&); + safe reverse(const safe&); + safe right(const safe&, const safe&, const safe&); + safe rtod(const safe&); + safe runerr(const safe&, const safe&); + safe runerr(const safe&); + safe seek(const safe&, const safe&); + safe serial(const safe&); + safe set(const safe&); + safe sin(const safe&); + safe sort(const safe&, const safe&); + safe sortf(const safe&, const safe&); + safe sqrt(const safe&); + safe stop(); + safe stop(const variadic&); + safe stop( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe string(const safe&); + safe system(const safe&); + safe table(const safe&); + safe tan(const safe&); + safe trim(const safe&, const safe&); + safe type(const safe&); + safe variable(const safe&); + safe where(const safe&); + safe write(); + safe write(const variadic&); + safe write( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + safe writes(const variadic&); + safe writes( const safe& x1, const safe& x2, + const safe& x3=illegal, const safe& x4=illegal, + const safe& x5=illegal, const safe& x6=illegal, + const safe& x7=illegal, const safe& x8=illegal ); + //generative functions follow, crippled to return a single value + safe any(const safe&, const safe&, const safe&, const safe&); + safe many(const safe&, const safe&, const safe&, const safe&); + safe upto(const safe&, const safe&, const safe&, const safe&); + safe find(const safe&, const safe&, const safe&, const safe&); + safe match(const safe&, const safe&, const safe&, const safe&); + safe bal(const safe&, const safe&, const safe&, const safe&, const safe&, const safe&); + safe move(const safe&); + safe tab(const safe&); +}; //namespace Icon + diff --git a/ipl/packs/loadfuncpp/loadfuncpp.icn b/ipl/packs/loadfuncpp/loadfuncpp.icn new file mode 100644 index 0000000..318ee99 --- /dev/null +++ b/ipl/packs/loadfuncpp/loadfuncpp.icn @@ -0,0 +1,241 @@ + +procedure loadfuncpp(fname, entry, arity) +#the first call loads the glue library, and loads and assigns the external loadfuncpp + local iload, fpath, oldloadfunc, real_loadfunc + real_loadfunc := _loadfuncpp_proc("loadfunc") + iload := _loadfuncpp_iload() + oldloadfunc := loadfunc #catch22: loadfunc cannot correctly return loadfuncpp + real_loadfunc(iload, "loadfuncpp") #implicitly assigns loadfuncpp to loadfunc on load + loadfuncpp := loadfunc #replace this loadfuncpp with the one loaded + loadfunc := oldloadfunc #put the old loadfunc back + self(iload) #initialize self from iload.so; calls loadfuncpp + bindself(iload) #initialize bindself from iload.so; calls loadfuncpp + loadfuncpp(_loadfuncpp_iloadgpx(), "iconx_graphics", 0) #calling Icon + return loadfuncpp(fname, entry, arity) #call the new loadfuncpp just loaded +end + +procedure self() + static getbinding + initial { + getbinding := loadfuncpp(_loadfuncpp_iload(), "getbinding", 0) | + stop("loadfuncpp: support function 'getbinding' not found in iload.so") + fail + } + return getbinding() #must be called from self() +end + +procedure bindself(proc, rec) + bindself := loadfuncpp(_loadfuncpp_iload(), "bindself", 2) | + stop("loadfuncpp: support functon 'bindself' not found in iload.so") + return bindself(proc, rec) +end + +invocable "_loadfuncpp_pathfind", "_loadfuncpp_reduce", "_loadfuncpp_create", + "_loadfuncpp_activate", "_loadfuncpp_kcollections", "_loadfuncpp_kfeatures", + "_loadfuncpp_kregions", "_loadfuncpp_kstorage", "_loadfuncpp_function", + "_loadfuncpp_bang", "_loadfuncpp_apply", "_loadfuncpp_any", "_loadfuncpp_many", + "_loadfuncpp_upto", "_loadfuncpp_find", "_loadfuncpp_match", "_loadfuncpp_bal", + "_loadfuncpp_move", "_loadfuncpp_tab", "_loadfuncpp_proc", "_loadfuncpp_key", + "_loadfuncpp_iload", "_loadfuncpp_iloadgpx" + +procedure _loadfuncpp_iload() + local getenv, fpath + static iload + initial { + getenv := _loadfuncpp_proc("getenv") + iload := _loadfuncpp_pathfind("iload.so", fpath:= getenv("FPATH")) | + stop("Cannot find iload.so on FPATH where \nFPATH=", fpath) + } + return iload +end + +procedure _loadfuncpp_iloadgpx() + local getenv, fpath, libname + static iloadgpx + initial { + if \Event then libname := "iloadgpx.so" else libname := "iloadnogpx.so" + getenv := _loadfuncpp_proc("getenv") + iloadgpx := _loadfuncpp_pathfind(libname, fpath:= getenv("FPATH")) | + stop("Cannot find ", libname, " on FPATH where \nFPATH=", fpath) + } + return iloadgpx +end + +procedure _loadfuncpp_pathfind(fname, path, psep) + local f, dir, fullname + static close, open, tab, upto, trim, many, pos + initial { + close := _loadfuncpp_proc("close") + open := _loadfuncpp_proc("open") + tab := _loadfuncpp_proc("tab") + upto := _loadfuncpp_proc("upto") + trim := _loadfuncpp_proc("trim") + many := _loadfuncpp_proc("many") + pos := _loadfuncpp_proc("pos") + } + /psep := ' :' #good for cygwin, unix variants (including OS X) + fname ? { + if ="/" & close(open(fname)) then + return fname #full absolute path works + while tab(upto('/') + 1) + fname := tab(0) #get final component of path + } + /path := "" + path := ". " || path + path ? while not pos(0) do { + dir := tab(upto(psep) | 0) + fullname := trim(dir, '/') || "/" || fname + if close(open(fullname)) then + return fullname + tab(many(psep)) + } + return #must return +end + +procedure _loadfuncpp_reduce(nullary, binary, g, arg) + local result + result := nullary + every binary(result, g!arg) + return result +end + +procedure _loadfuncpp_create(g, arg) + return create g!arg +end + +procedure _loadfuncpp_activate(coexp, val) + return val@coexp | &null +end + +procedure _loadfuncpp_kcollections() + local ls + ls := [] + every put(ls, &collections) + return ls +end + +procedure _loadfuncpp_kfeatures() + local ls + ls := [] + every put(ls, &features) + return ls +end + +procedure _loadfuncpp_kregions() + local ls + ls := [] + every put(ls, ®ions) + return ls +end + +procedure _loadfuncpp_kstorage() + local ls + ls := [] + every put(ls, &storage) + return ls +end + +procedure _loadfuncpp_function() + local ls + static function + initial function := _loadfuncpp_proc("function") + ls := [] + every put(ls, function()) + return ls +end + +procedure _loadfuncpp_key(t) + local ls + static key + initial key := _loadfuncpp_proc("key") + ls := [] + every put(ls, key(t)) + return ls +end + +procedure _loadfuncpp_bang(nullary, binary, x) + local result + result := nullary + if type(x)=="table" + then every binary(result, key(x)) + else every binary(result, !x) + return result +end + +procedure _loadfuncpp_any(c,s,i1,i2) + static any + initial any := _loadfuncpp_proc("any") + return any(c,s,i1,i2) | &null +end + +procedure _loadfuncpp_many(c,s,i1,i2) + static many + initial many := _loadfuncpp_proc("many") + return many(c,s,i1,i2) | &null +end + +procedure _loadfuncpp_upto(c,s,i1,i2) + static upto + initial upto := _loadfuncpp_proc("upto") + return upto(c,s,i1,i2) | &null +end + +procedure _loadfuncpp_find(s1,s2,i1,i2) + static find + initial find := _loadfuncpp_proc("find") + return find(s1,s2,i1,i2) | &null +end + +procedure _loadfuncpp_match(s1,s2,i1,i2) + static match + initial match := _loadfuncpp_proc("match") + return match(s1,s2,i1,i2) | &null +end + +procedure _loadfuncpp_bal(c1,c2,c3,s,i1,i2) + static bal + initial bal := _loadfuncpp_proc("bal") + return bal(c1,c2,c3,s,i1,i2) | &null +end + +procedure _loadfuncpp_move(i) + static move + initial move := _loadfuncpp_proc("move") + return move(i) | &null +end + +procedure _loadfuncpp_tab(i) + static tab + initial tab := _loadfuncpp_proc("tab") + return tab(i) | &null +end + +procedure _loadfuncpp_apply(f, arg) + return f!arg | &null +end + +#use to find built-in functions so they can be nobbled +#prior to the first call of loadfuncpp without affecting us +#this is a defensive measure to protect a reasonable programmer +#NOT an attempt to be secure against all ways to subvert loadfuncpp +procedure _loadfuncpp_proc(function) + static Proc + local errmsg + initial { + #called when procedure loadfuncpp is first called to load the real loadfuncpp + errmsg := "loadfuncpp: built-in function 'proc' not found" + Proc := proc("proc",0) | stop(errmsg) + image(Proc)=="function proc" | stop(errmsg) + args(Proc)=2 | stop(errmsg) + Proc("proc",0)===Proc | stop(errmsg) #good enough, not perfect + } + return Proc(function,0) | &null +end + + + + + + + + diff --git a/ipl/packs/loadfuncpp/loadfuncpp_build.sh b/ipl/packs/loadfuncpp/loadfuncpp_build.sh new file mode 100755 index 0000000..60b85ae --- /dev/null +++ b/ipl/packs/loadfuncpp/loadfuncpp_build.sh @@ -0,0 +1,32 @@ +#!/bin/bash + +set -o verbose #echo on + +#loadfuncpp itself +make clean +make + +pushd cgi +make +popd + +#pushd icondb +#make +#popd + +pushd socket +make clean +make +popd + +pushd system +make clean +make +popd + +pushd openssl +make clean +make +popd + +set +o verbose #echo off diff --git a/ipl/packs/loadfuncpp/savex.icn b/ipl/packs/loadfuncpp/savex.icn new file mode 100644 index 0000000..7000f5d --- /dev/null +++ b/ipl/packs/loadfuncpp/savex.icn @@ -0,0 +1,41 @@ + +procedure main(arg) + usage := "Copies iexample.icn and iexample.cpp to doc/<name>.icn\n" || + "and <name>.cpp to doc/<name>.cpp\nUsage: savex <name>" + exname := !arg | stop(usage) + examples := open("doc/examples.txt") | stop("Unable to open doc/examples.txt") + template := open("doc/Makefile.mak") | stop("Unable to open doc/Makefile.mak") + makefile := open("doc/Makefile", "w") | stop("Unable to open doc/Makefile") + in := open("iexample.icn") | stop("Unable to open iexample.icn") + out := open("doc/"||exname||".icn", "w") | stop("Unable to open "||exname||".icn") + ls := [exname] + while put(ls, ""~==trim(read(examples), ' \t')) + ls := sort(ls) + write(makefile, "\n#Automatically generated from Makefile.mak and examples.txt by ../savex.icn") + while line := read(template) do line ? { + if writes(makefile, tab(find("#exe#"))) then { + every writes(makefile, !ls, ".exe ") + write(makefile) + next + } + if writes(makefile, tab(find("#so#"))) then { + every writes(makefile, !ls, ".so ") + write(makefile) + next + } + write(makefile, line) + } + while line := read(in) do line ? { + if p := find("iexample.so") then { + writes(out, tab(p)) + writes(out, exname) + ="iexample" + write(out, tab(0)) + } else write(out, line) + } + every close(examples|template|makefile|in|out) + system("cp iexample.cpp doc/" || exname || ".cpp") + examples := open("doc/examples.txt", "w") | stop("Unable to open doc/examples.txt") + every write(examples, !ls) +end + diff --git a/ipl/packs/loadfuncpp/xfload.cpp b/ipl/packs/loadfuncpp/xfload.cpp new file mode 100644 index 0000000..2120248 --- /dev/null +++ b/ipl/packs/loadfuncpp/xfload.cpp @@ -0,0 +1,239 @@ +/* + * Sun Mar 23 09:43:59 2008 + * This file was produced by + * rtt: Icon Version 9.5.a-C, Autumn, 2007 + */ +// and then modified by cs + + +#define COMPILER 0 +extern "C" { +#include RTT +} + +//#line 42 "fload.r" + +//int glue(); //cs +//int makefunc(dptr d, char *name, int (*func)()); //cs +//int Zloadfunc (dptr r_args); //cs +//FncBlock(loadfunc, 2, 0) //cs + +//cs new makefunc that allocates a proc_block +static int newmakefunc(dptr d, char *name, int (*func)(), int arity) { + value nom(NewString,name); + proc_block* pbp; + if( arity < 0 ) pbp = new proc_block(nom, (iconfvbl*)func); + else pbp = new proc_block(nom, (iconfunc*)func, arity); + if( pbp==0 ) return 0; + d->dword = D_Proc; + d->vword.bptr = (union block *)pbp; + return 1; +} +//cs end of new makefunc + +//int Zloadfunc(r_args) //cs +//dptr r_args; //cs +inline int Z_loadfunc(dptr r_args) //cs + { + if (!cnv_c_str(&(r_args[1]), &(r_args[1]))) { + { + err_msg( + +//#line 50 "fload.r" + + 103, &(r_args[1])); + return A_Resume; + } + } + +//#line 51 "fload.r" + + if (!cnv_c_str(&(r_args[2]), &(r_args[2]))) { + { + err_msg( + +//#line 52 "fload.r" + + 103, &(r_args[2])); + return A_Resume; + } + } +//cs new third parameter: arity + C_integer r_i2; + if (!cnv_c_int(&(r_args[3]), &(r_i2))) { + err_msg(101, &(r_args[3])); + return A_Resume; + } +//cs end new third arity parameter + +//#line 58 "fload.r" + + { + int (*func)(); + static char *curfile; + static void *handle; + char *funcname2; + +//#line 67 "fload.r" + + if (!handle || !curfile || strcmp(r_args[1].vword.sptr, curfile) != 0) { + if (curfile) + free((pointer)curfile); + curfile = salloc(r_args[1].vword.sptr); + handle = dlopen(r_args[1].vword.sptr, 1 | RTLD_GLOBAL); + } + +//#line 76 "fload.r" + + if (handle) { + func = (int (*)())dlsym(handle, r_args[2].vword.sptr); + if (!func) { + +//#line 83 "fload.r" + + //funcname2 = malloc(strlen(r_args[2].vword.sptr) + 2); //cs + funcname2 = (char*)malloc(strlen(r_args[2].vword.sptr) + 2); //cs + if (funcname2) { + *funcname2 = '_'; + strcpy(funcname2 + 1, r_args[2].vword.sptr); + func = (int (*)())dlsym(handle, funcname2); + free(funcname2); + } + } + } + if (!handle || !func) { + //fprintf(stderr, "\nloadfunc(\"%s\",\"%s\"): %s\n", //cs + fprintf(stderr, "\nloadfuncpp(\"%s\",\"%s\"): %s\n", //cs + r_args[1].vword.sptr, r_args[2].vword.sptr, dlerror()); + { + err_msg( + +//#line 95 "fload.r" + + 216, NULL); + return A_Resume; + } + } + +// if (!makefunc(&r_args[0], r_args[2].vword.sptr, func)) //cs + if (!newmakefunc(&r_args[0], r_args[2].vword.sptr, func, r_i2)) //cs + { + err_msg( + +//#line 101 "fload.r" + + 305, NULL); + return A_Resume; + } + { + return A_Continue; + } + } + } + + +#if 0 //cs --- not used: we use a proc_block constructor, and no glue + +//#line 111 "fload.r" + +int makefunc(d, name, func) +dptr d; +char *name; +int (*func)(); + { + struct b_proc *blk; + + blk = (struct b_proc *)malloc(sizeof(struct b_proc)); + if (!blk) + return 0; + blk->title = T_Proc; + blk->blksize = sizeof(struct b_proc); + +//#line 127 "fload.r" + + blk->entryp.ccode = glue; + +//#line 130 "fload.r" + + blk->nparam = -1; + blk->ndynam = -1; + blk->nstatic = 0; + blk->fstatic = 0; + blk->pname.dword = strlen(name); + blk->pname.vword.sptr = salloc(name); + blk->lnames[0].dword = 0; + blk->lnames[0].vword.sptr = (char *)func; + + d->dword = D_Proc; + d->vword.bptr = (union block *)blk; + return 1; + } + +//#line 190 "fload.r" + +int glue(argc, dargv) +int argc; +dptr dargv; + { + int status, (*func)(); + struct b_proc *blk; + struct descrip r; + struct { + struct tend_desc *previous; + int num; + struct descrip d[1]; + } r_tend; + + r_tend.d[0].dword = D_Null; + r_tend.num = 1; + r_tend.previous = tend; + tend = (struct tend_desc *)&r_tend; + +//#line 199 "fload.r" + + blk = (struct b_proc *)dargv[0].vword.bptr; + func = (int (*)())blk->lnames[0].vword.sptr; + + r_tend.d[0] = dargv[0]; + dargv[0] = nulldesc; + status = (*func)(argc, dargv); + + if (status == 0) { + tend = r_tend.previous; + +//#line 207 "fload.r" + + return A_Continue; + } + +//#line 208 "fload.r" + + if (status < 0) { + tend = r_tend.previous; + +//#line 209 "fload.r" + + return A_Resume; + } + r = dargv[0]; + dargv[0] = r_tend.d[0]; + if (((r).dword == D_Null)) + do {err_msg((int)status, NULL);{ + tend = r_tend.previous; + return A_Resume; + } + } + while (0); + +//#line 215 "fload.r" + + do {err_msg((int)status, &r);{ + tend = r_tend.previous; + return A_Resume; + } + } + while (0); + } + +#endif //cs unused + diff --git a/ipl/packs/loadfuncpp/xinterp.cpp b/ipl/packs/loadfuncpp/xinterp.cpp new file mode 100644 index 0000000..dba8f27 --- /dev/null +++ b/ipl/packs/loadfuncpp/xinterp.cpp @@ -0,0 +1,1647 @@ +/* + * Tue Feb 12 18:19:56 2008 + * This file was produced by + * rtt: Icon Version 9.5.a-C, Autumn, 2007 + */ +//and then modified by cs + + +extern "C" { //cs + +#define COMPILER 0 +#include RTT + +//#line 8 "interp.r" + +extern fptr fncentry[]; + +//#line 22 "interp.r" + +//word lastop; +extern word lastop; //cs + +//#line 28 "interp.r" + +//struct ef_marker *efp; +extern struct ef_marker *efp; //cs +//struct gf_marker *gfp; +extern struct gf_marker *gfp; //cs +//inst ipc; +extern inst ipc; //cs +//word *sp = NULL; +extern word *sp; //cs + +//int ilevel; +extern int ilevel; //cs +//struct descrip value_tmp; +extern struct descrip value_tmp; //cs +//struct descrip eret_tmp; +extern struct descrip eret_tmp; //cs + +//int coexp_act; +extern int coexp_act; //cs + +//#line 40 "interp.r" + +//dptr xargp; +extern dptr xargp; //cs +//word xnargs; +extern word xnargs; //cs + +//#line 155 "interp.r" + +//int interp(fsig, cargp) +//int fsig; +//dptr cargp; +static int icall(dptr procptr, dptr arglistptr, dptr result) //cs + { + register word opnd; + register word *rsp; + register dptr rargp; + register struct ef_marker *newefp; + register struct gf_marker *newgfp; + register word *wd; + register word *firstwd, *lastwd; + word *oldsp; + int type, signal, args; +// extern int (*optab[])(); + extern int (*optab[])(dptr); //cs +// extern int (*keytab[])(); + extern int (*keytab[])(dptr); //cs + struct b_proc *bproc; + word savedlastop = lastop; //cs --- so that Icon::runerr works as expected through ttrace + dptr oldxargp = xargp; //cs --- save the arguments passed to the C++ function calling Icon + int oldxnargs = xnargs; //cs --- ditto + dptr lval; //cs + int fsig = 0; //cs + dptr cargp = (dptr)(sp+1); //cs + dptr return_cargp = cargp; //cs + word *saved_sp = sp; //cs + word *return_sp = sp + 2; //cs + + cargp[0] = *procptr; //cs + cargp[1] = *arglistptr; //cs + sp += 4; //cs + +//#line 189 "interp.r" + + if (BlkLoc(k_current) == BlkLoc(k_main) && + ((char *)sp + PerilDelta) > (char *)stackend) + fatalerr(301, NULL); + +//#line 195 "interp.r" + +#if GPX //cs + if (!pollctr--) { + pollctr = pollevent(); + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 201 "interp.r" + + ilevel++; + + rsp = sp;; + +//#line 215 "interp.r" + + if (fsig == G_Csusp) { + +//#line 218 "interp.r" + + oldsp = rsp; + +//#line 223 "interp.r" + + newgfp = (struct gf_marker *)(rsp + 1); + newgfp->gf_gentype = fsig; + newgfp->gf_gfp = gfp; + newgfp->gf_efp = efp; + newgfp->gf_ipc = ipc; + rsp += ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + +//#line 235 "interp.r" + + if (gfp != 0) { + if (gfp->gf_gentype == G_Psusp) + firstwd = (word *)gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)gfp + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)cargp + 1; + +//#line 249 "interp.r" + + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + gfp = newgfp; + } + +//#line 257 "interp.r" + + goto apply; //cs + + for (; ; ) { + +//#line 330 "interp.r" + + lastop = (word)(*ipc.op++); + + if( rsp < return_sp ) //cs + syserror("loadfuncpp: call of Icon from C++ must return a value, yet failed instead"); + +//#line 348 "interp.r" + + switch ((int)lastop) { + +//#line 359 "interp.r" + + case 51: + ipc.op[-1] = (90); + PushValSP(rsp, D_Cset); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + ipc.opnd[-1] = (opnd); + PushValSP(rsp, opnd); + break; + + case 90: + PushValSP(rsp, D_Cset); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 60: + PushValSP(rsp, D_Integer); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 75: + ipc.op[-1] = (91); + PushValSP(rsp, D_Real); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + PushValSP(rsp, opnd); + ipc.opnd[-1] = (opnd); + break; + + case 91: + PushValSP(rsp, D_Real); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 77: + ipc.op[-1] = (92); + PushValSP(rsp, (*ipc.opnd++)); + opnd = (word)strcons + (*ipc.opnd++); + ipc.opnd[-1] = (opnd); + PushValSP(rsp, opnd); + break; + + case 92: + PushValSP(rsp, (*ipc.opnd++)); + PushValSP(rsp, (*ipc.opnd++)); + break; + +//#line 407 "interp.r" + + case 81: + PushValSP(rsp, D_Var); + PushValSP(rsp, &glbl_argp[(*ipc.opnd++) + 1]); + break; + + case 84: + ipc.op[-1] = (93); + PushValSP(rsp, D_Var); + opnd = (*ipc.opnd++); + PushValSP(rsp, &globals[opnd]); + ipc.opnd[-1] = ((word)&globals[opnd]); + break; + + case 93: + PushValSP(rsp, D_Var); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 83: + PushValSP(rsp, D_Var); + PushValSP(rsp, &pfp->pf_locals[(*ipc.opnd++)]); + break; + + case 82: + ipc.op[-1] = (94); + PushValSP(rsp, D_Var); + opnd = (*ipc.opnd++); + PushValSP(rsp, &statics[opnd]); + ipc.opnd[-1] = ((word)&statics[opnd]); + break; + + case 94: + PushValSP(rsp, D_Var); + PushValSP(rsp, (*ipc.opnd++)); + break; + +//#line 448 "interp.r" + + case 4: + case 19: + case 23: + case 34: + case 37: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 453 "interp.r" + + ; + Deref(rargp[1]); + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 455 "interp.r" + + ; + + case 43: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 458 "interp.r" + + ; + Deref(rargp[1]); + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 460 "interp.r" + + ; + + case 21: + case 22: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 464 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 465 "interp.r" + + ; + + case 32: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 474 "interp.r" + + case 40: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 475 "interp.r" + + ; + Deref(rargp[1]); + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 477 "interp.r" + + ; + + case 2: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 481 "interp.r" + + ; + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 482 "interp.r" + + ; + +//#line 486 "interp.r" + + case 3: + case 5: + case 6: + case 8: + case 9: + case 16: + case 17: + case 18: + case 31: + case 42: + case 30: + case 7: + case 10: + case 11: + case 12: + case 13: + case 14: + case 15: + case 20: + case 24: + case 25: + case 26: + case 27: + case 29: + case 28: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 511 "interp.r" + + ; + Deref(rargp[1]); + Deref(rargp[2]); + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 514 "interp.r" + + ; + + case 1: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 517 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 518 "interp.r" + + ; + + case 39: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 522 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 523 "interp.r" + + ; + + case 38: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 527 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 528 "interp.r" + + ; + +//#line 531 "interp.r" + + case 33: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 532 "interp.r" + + ; + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 533 "interp.r" + + ; + + case 35: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 537 "interp.r" + + ; + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 538 "interp.r" + + ; + +//#line 542 "interp.r" + + case 36: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 4; + xargp = rargp; + sp = rsp;; + +//#line 544 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 545 "interp.r" + + ; + +//#line 548 "interp.r" + + case 41: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 549 "interp.r" + + ; + Deref(rargp[1]); + Deref(rargp[2]); + Deref(rargp[3]); + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 553 "interp.r" + + ; + + case 98: + +//#line 559 "interp.r" + +#if GPX //cs + if (!pollctr--) { + sp = rsp;; + pollctr = pollevent(); + rsp = sp;; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 570 "interp.r" + + break; + +//#line 573 "interp.r" + + case 108: + { + +//#line 583 "interp.r" + + break; + } + + case 64: + +//#line 590 "interp.r" + +#if GPX //cs + if (!pollctr--) { + sp = rsp;; + pollctr = pollevent(); + rsp = sp;; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 606 "interp.r" + + break; + +//#line 610 "interp.r" + + case 44: + PushDescSP(rsp, k_subject); + PushValSP(rsp, D_Integer); + PushValSP(rsp, k_pos); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 614 "interp.r" + + ; + + signal = Obscan(2, rargp); + + goto C_rtn_term; + + case 55: + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 621 "interp.r" + + ; + + signal = Oescan(1, rargp); + + goto C_rtn_term; + +//#line 629 "interp.r" + + case 89: { + apply: //cs + union block *bp; + int i, j; + + value_tmp = *(dptr)(rsp - 1); + Deref(value_tmp); + switch (Type(value_tmp)) { + case T_List: { + rsp -= 2; + bp = BlkLoc(value_tmp); + args = (int)bp->list.size; + +//#line 647 "interp.r" + + if (BlkLoc(k_current) == BlkLoc(k_main) && + ((char *)sp + args * sizeof(struct descrip) > + (char *)stackend)) + fatalerr(301, NULL); + +//#line 653 "interp.r" + + for (bp = bp->list.listhead; + +//#line 657 "interp.r" + + bp != NULL; + + bp = bp->lelem.listnext) { + for (i = 0; i < bp->lelem.nused; i++) { + j = bp->lelem.first + i; + if (j >= bp->lelem.nslots) + j -= bp->lelem.nslots; + PushDescSP(rsp, bp->lelem.lslots[j]); + } + } + goto invokej; + } + + case T_Record: { + rsp -= 2; + bp = BlkLoc(value_tmp); + args = bp->record.recdesc->proc.nfields; + for (i = 0; i < args; i++) { + PushDescSP(rsp, bp->record.fields[i]); + } + goto invokej; + } + + default: { + + xargp = (dptr)(rsp - 3); + err_msg(126, &value_tmp); + goto efail; + } + } + } + + case 61: { + args = (int)(*ipc.opnd++); + invokej: + { + int nargs; + dptr carg; + + sp = rsp;; + type = invoke(args, &carg, &nargs); + rsp = sp;; + + if (type == I_Fail) + goto efail_noev; + if (type == I_Continue) + break; + else { + + rargp = carg; + +//#line 712 "interp.r" + +#if GPX //cs + pollctr >>= 1; + if (!pollctr) { + sp = rsp;; + pollctr = pollevent(); + rsp = sp;; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 726 "interp.r" + + bproc = (struct b_proc *)BlkLoc(*rargp); + +//#line 734 "interp.r" + + if (type == I_Vararg) { +// int (*bfunc)(); + int (*bfunc)(int, dptr); //cs +// bfunc = bproc->entryp.ccode; + bfunc = (int (*)(int,dptr))(bproc->entryp.ccode); + +//#line 741 "interp.r" + + signal = (*bfunc)(nargs, rargp); + } + else + +//#line 746 "interp.r" + + { +// int (*bfunc)(); + int (*bfunc)(dptr); +// bfunc = bproc->entryp.ccode; + bfunc = (int (*)(dptr))(bproc->entryp.ccode); + +//#line 753 "interp.r" + + signal = (*bfunc)(rargp); + } + +//#line 767 "interp.r" + + goto C_rtn_term; + } + } + } + + case 62: + + PushNullSP(rsp); + opnd = (*ipc.opnd++); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 0; + xargp = rargp; + sp = rsp;; + +//#line 776 "interp.r" + + ; + + signal = (*(keytab[(int)opnd]))(rargp); + goto C_rtn_term; + + case 65: + opnd = (*ipc.opnd++); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - opnd; + xargp = rargp; + sp = rsp;; + +//#line 793 "interp.r" + + ; + +//#line 796 "interp.r" + + { + int i; + for (i = 1; i <= opnd; i++) + Deref(rargp[i]); + } + + signal = Ollist((int)opnd, rargp); + + goto C_rtn_term; + +//#line 808 "interp.r" + + case 67: + ipc.op[-1] = (96); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + ipc.opnd[-1] = (opnd); + newefp = (struct ef_marker *)(rsp + 1); + newefp->ef_failure.opnd = (word *)opnd; + goto mark; + + case 96: + newefp = (struct ef_marker *)(rsp + 1); + newefp->ef_failure.opnd = (word *)(*ipc.opnd++); + mark: + newefp->ef_gfp = gfp; + newefp->ef_efp = efp; + newefp->ef_ilevel = ilevel; + rsp += ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + efp = newefp; + gfp = 0; + break; + + case 85: + mark0: + newefp = (struct ef_marker *)(rsp + 1); + newefp->ef_failure.opnd = 0; + newefp->ef_gfp = gfp; + newefp->ef_efp = efp; + newefp->ef_ilevel = ilevel; + rsp += ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + efp = newefp; + gfp = 0; + break; + + case 78: + +//#line 849 "interp.r" + + gfp = efp->ef_gfp; + rsp = (word *)efp - 1; + +//#line 855 "interp.r" + + Unmark_uw: + if (efp->ef_ilevel < ilevel) { + --ilevel; + + sp = rsp;; + +//#line 866 "interp.r" + + return A_Unmark_uw; + } + + efp = efp->ef_efp; + break; + +//#line 874 "interp.r" + + case 56: { + +//#line 879 "interp.r" + + oldsp = rsp; + newgfp = (struct gf_marker *)(rsp + 1); + newgfp->gf_gentype = G_Esusp; + newgfp->gf_gfp = gfp; + newgfp->gf_efp = efp; + newgfp->gf_ipc = ipc; + gfp = newgfp; + rsp += ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + +//#line 892 "interp.r" + + if (efp->ef_gfp != 0) { + newgfp = (struct gf_marker *)(efp->ef_gfp); + if (newgfp->gf_gentype == G_Psusp) + firstwd = (word *)efp->ef_gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)efp->ef_gfp + + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)efp->ef_efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)efp - 1; + efp = efp->ef_efp; + +//#line 909 "interp.r" + + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + PushValSP(rsp, oldsp[-1]); + PushValSP(rsp, oldsp[0]); + break; + } + + case 66: { + struct descrip sval; + +//#line 924 "interp.r" + +// dptr lval = (dptr)((word *)efp - 2); + lval = (dptr)((word *)efp - 2); //cs + +//#line 929 "interp.r" + + if (--IntVal(*lval) > 0) { + +//#line 934 "interp.r" + + sval = *(dptr)(rsp - 1); + +//#line 941 "interp.r" + + if (efp->ef_gfp != 0) { + newgfp = (struct gf_marker *)(efp->ef_gfp); + if (newgfp->gf_gentype == G_Psusp) + firstwd = (word *)efp->ef_gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)efp->ef_gfp + + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)efp->ef_efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)efp - 3; + if (gfp == 0) + gfp = efp->ef_gfp; + efp = efp->ef_efp; + +//#line 960 "interp.r" + + rsp -= 2; + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + PushDescSP(rsp, sval); + } + else { + +//#line 973 "interp.r" + + *lval = *(dptr)(rsp - 1); + +//#line 981 "interp.r" + + gfp = efp->ef_gfp; + +//#line 987 "interp.r" + + Lsusp_uw: + if (efp->ef_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 997 "interp.r" + + return A_Lsusp_uw; + } + rsp = (word *)efp - 1; + efp = efp->ef_efp; + } + break; + } + + case 72: { + +//#line 1015 "interp.r" + + struct descrip tmp; + dptr svalp; + struct b_proc *sproc; + +//#line 1025 "interp.r" + + svalp = (dptr)(rsp - 1); + if (Var(*svalp)) { + sp = rsp;; + retderef(svalp, (word *)glbl_argp, sp); + rsp = sp;; + } + +//#line 1035 "interp.r" + + oldsp = rsp; + newgfp = (struct gf_marker *)(rsp + 1); + newgfp->gf_gentype = G_Psusp; + newgfp->gf_gfp = gfp; + newgfp->gf_efp = efp; + newgfp->gf_ipc = ipc; + newgfp->gf_argp = glbl_argp; + newgfp->gf_pfp = pfp; + gfp = newgfp; + rsp += ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + +//#line 1051 "interp.r" + + if (pfp->pf_gfp != 0) { + newgfp = (struct gf_marker *)(pfp->pf_gfp); + if (newgfp->gf_gentype == G_Psusp) + firstwd = (word *)pfp->pf_gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)pfp->pf_gfp + + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)pfp->pf_efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)glbl_argp - 1; + efp = efp->ef_efp; + +//#line 1068 "interp.r" + + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + PushValSP(rsp, oldsp[-1]); + PushValSP(rsp, oldsp[0]); + --k_level; + if (k_trace) { + k_trace--; + sproc = (struct b_proc *)BlkLoc(*glbl_argp); + strace(&(sproc->pname), svalp); + } + +//#line 1083 "interp.r" + + if (pfp->pf_scan != NULL) { + +//#line 1089 "interp.r" + + tmp = k_subject; + k_subject = *pfp->pf_scan; + *pfp->pf_scan = tmp; + + tmp = *(pfp->pf_scan + 1); + IntVal(*(pfp->pf_scan + 1)) = k_pos; + k_pos = IntVal(tmp); + } + +//#line 1106 "interp.r" + + efp = pfp->pf_efp; + ipc = pfp->pf_ipc; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + break; + } + +//#line 1115 "interp.r" + + case 54: { + +//#line 1124 "interp.r" + + eret_tmp = *(dptr)&rsp[-1]; + gfp = efp->ef_gfp; + Eret_uw: + +//#line 1131 "interp.r" + + if (efp->ef_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 1140 "interp.r" + + return A_Eret_uw; + } + rsp = (word *)efp - 1; + efp = efp->ef_efp; + PushDescSP(rsp, eret_tmp); + break; + } + +//#line 1149 "interp.r" + + case 71: { + +//#line 1163 "interp.r" + + struct b_proc *rproc; + rproc = (struct b_proc *)BlkLoc(*glbl_argp); + +//#line 1173 "interp.r" + + *glbl_argp = *(dptr)(rsp - 1); + if (Var(*glbl_argp)) { + sp = rsp;; + retderef(glbl_argp, (word *)glbl_argp, sp); + rsp = sp;; + } + + --k_level; + if (k_trace) { + k_trace--; + rtrace(&(rproc->pname), glbl_argp); + } + Pret_uw: + if (pfp->pf_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 1196 "interp.r" + + return A_Pret_uw; + } + +//#line 1203 "interp.r" + + rsp = (word *)glbl_argp + 1; + efp = pfp->pf_efp; + gfp = pfp->pf_gfp; + ipc = pfp->pf_ipc; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + +//#line 1219 "interp.r" + +//cs return to C++ + if( rsp == return_sp ) { + --ilevel; + *result = *return_cargp; + sp = saved_sp; + lastop = savedlastop; + xargp = oldxargp; + xnargs = oldxnargs; + return 0; + } +//cs end return to C++ + break; + } + +//#line 1224 "interp.r" + + case 53: + efail: + +//#line 1229 "interp.r" + + efail_noev: + +//#line 1233 "interp.r" + + if (gfp == 0) { + +//#line 1251 "interp.r" + + ipc = efp->ef_failure; + gfp = efp->ef_gfp; + rsp = (word *)efp - 1; + efp = efp->ef_efp; + + if (ipc.op == 0) + goto efail; + break; + } + else + { + +//#line 1267 "interp.r" + + struct descrip tmp; + register struct gf_marker *resgfp = gfp; + + type = (int)resgfp->gf_gentype; + + if (type == G_Psusp) { + glbl_argp = resgfp->gf_argp; + if (k_trace) { + k_trace--; + sp = rsp;; + atrace(&(((struct b_proc *)BlkLoc(*glbl_argp))->pname)); + rsp = sp;; + } + } + ipc = resgfp->gf_ipc; + efp = resgfp->gf_efp; + gfp = resgfp->gf_gfp; + rsp = (word *)resgfp - 1; + if (type == G_Psusp) { + pfp = resgfp->gf_pfp; + +//#line 1292 "interp.r" + + if (pfp->pf_scan != NULL) { + tmp = k_subject; + k_subject = *pfp->pf_scan; + *pfp->pf_scan = tmp; + + tmp = *(pfp->pf_scan + 1); + IntVal(*(pfp->pf_scan + 1)) = k_pos; + k_pos = IntVal(tmp); + } + +//#line 1313 "interp.r" + + ++k_level; + } + + switch (type) { + +//#line 1336 "interp.r" + + case G_Csusp: + ; + --ilevel; + sp = rsp;; + +//#line 1344 "interp.r" + + return A_Resume; + + case G_Esusp: + ; + goto efail_noev; + + case G_Psusp: + ; + break; + } + + break; + } + + case 68: { + +//#line 1374 "interp.r" + + --k_level; + if (k_trace) { + k_trace--; + failtrace(&(((struct b_proc *)BlkLoc(*glbl_argp))->pname)); + } + Pfail_uw: + + if (pfp->pf_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 1388 "interp.r" + + return A_Pfail_uw; + } + efp = pfp->pf_efp; + gfp = pfp->pf_gfp; + ipc = pfp->pf_ipc; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + +//#line 1406 "interp.r" + + goto efail_noev; + } + +//#line 1410 "interp.r" + + case 45: + PushNullSP(rsp); + PushValSP(rsp, ((word *)efp)[-2]); + PushValSP(rsp, ((word *)efp)[-1]); + break; + + case 46: + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + efp->ef_failure.opnd = (word *)opnd; + break; + + case 52: + PushNullSP(rsp); + rsp[1] = rsp[-3]; + rsp[2] = rsp[-2]; + rsp += 2; + break; + + case 57: + PushValSP(rsp, D_Integer); + PushValSP(rsp, (*ipc.opnd++)); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 1432 "interp.r" + + ; + + signal = Ofield(2, rargp); + + goto C_rtn_term; + + case 58: + ipc.op[-1] = (95); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + ipc.opnd[-1] = (opnd); + ipc.opnd = (word *)opnd; + break; + + case 95: + opnd = (*ipc.opnd++); + ipc.opnd = (word *)opnd; + break; + + case 59: + *--ipc.op = 58; + opnd = sizeof((*ipc.op)) + sizeof((*rsp)); + opnd += (word)ipc.opnd; + ipc.opnd = (word *)opnd; + break; + + case 63: + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 0; + xargp = rargp; + sp = rsp;; + +//#line 1459 "interp.r" + + ; + + if (Olimit(0, rargp) == A_Resume) { + +//#line 1468 "interp.r" + + goto efail_noev; + } + else { + +//#line 1476 "interp.r" + + rsp = (word *)rargp + 1; + } + goto mark0; + +//#line 1486 "interp.r" + + case 69: + PushNullSP(rsp); + break; + + case 70: + rsp -= 2; + break; + + case 73: + PushValSP(rsp, D_Integer); + PushValSP(rsp, 1); + break; + + case 74: + PushValSP(rsp, D_Integer); + PushValSP(rsp, -1); + break; + + case 76: + rsp += 2; + rsp[-1] = rsp[-3]; + rsp[0] = rsp[-2]; + break; + +//#line 1512 "interp.r" + + case 50: + +//#line 1515 "interp.r" + + PushNullSP(rsp); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 0; + xargp = rargp; + sp = rsp;; + +//#line 1516 "interp.r" + + ; + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + + signal = Ocreate((word *)opnd, rargp); + + goto C_rtn_term; + +//#line 1528 "interp.r" + + case 47: { + +//#line 1534 "interp.r" + + struct b_coexpr *ncp; + dptr dp; + + sp = rsp;; + dp = (dptr)(sp - 1); + xargp = dp - 2; + + Deref(*dp); + if (dp->dword != D_Coexpr) { + err_msg(118, dp); + goto efail; + } + + ncp = (struct b_coexpr *)BlkLoc(*dp); + + signal = activate((dptr)(sp - 3), ncp, (dptr)(sp - 3)); + rsp = sp;; + if (signal == A_Resume) + goto efail_noev; + else + rsp -= 2; + + break; + } + + case 49: { + +//#line 1564 "interp.r" + + struct b_coexpr *ncp; + + sp = rsp;; + ncp = popact((struct b_coexpr *)BlkLoc(k_current)); + + ++BlkLoc(k_current)->coexpr.size; + co_chng(ncp, (dptr)&sp[-1], NULL, A_Coret, 1); + rsp = sp;; + + break; + } + +//#line 1577 "interp.r" + + case 48: { + +//#line 1582 "interp.r" + + struct b_coexpr *ncp; + + sp = rsp;; + ncp = popact((struct b_coexpr *)BlkLoc(k_current)); + + co_chng(ncp, NULL, NULL, A_Cofail, 1); + rsp = sp;; + + break; + } + + case 86: + +//#line 1596 "interp.r" + + goto interp_quit; + +//#line 1599 "interp.r" + + default: { + char buf[50]; + + sprintf(buf, "unimplemented opcode: %ld (0x%08x)\n", + (long)lastop, lastop); + syserr(buf); + } + } + continue; + + C_rtn_term: + rsp = sp;; + + switch (signal) { + + case A_Resume: + +//#line 1622 "interp.r" + + goto efail_noev; + + case A_Unmark_uw: + +//#line 1631 "interp.r" + + goto Unmark_uw; + + case A_Lsusp_uw: + +//#line 1640 "interp.r" + + goto Lsusp_uw; + + case A_Eret_uw: + +//#line 1649 "interp.r" + + goto Eret_uw; + + case A_Pret_uw: + +//#line 1658 "interp.r" + + goto Pret_uw; + + case A_Pfail_uw: + +//#line 1667 "interp.r" + + goto Pfail_uw; + } + + rsp = (word *)rargp + 1; + +//#line 1682 "interp.r" + + continue; + } + + interp_quit: + --ilevel; + if (ilevel != 0) + syserror("interp: termination with inactive generators."); + + return 0; + } + +} //cs --- extern "C" diff --git a/ipl/packs/loadfuncpp/xinterp64.cpp b/ipl/packs/loadfuncpp/xinterp64.cpp new file mode 100644 index 0000000..63ffe37 --- /dev/null +++ b/ipl/packs/loadfuncpp/xinterp64.cpp @@ -0,0 +1,1642 @@ +/* + * Tue Feb 12 18:19:56 2008 + * This file was produced by + * rtt: Icon Version 9.5.a-C, Autumn, 2007 + */ +//and then modified by cs + + +extern "C" { //cs + +#define COMPILER 0 +#include RTT + +//#line 8 "interp.r" + +extern fptr fncentry[]; + +//#line 22 "interp.r" + +//word lastop; +extern word lastop; //cs + +//#line 28 "interp.r" + +//struct ef_marker *efp; +extern struct ef_marker *efp; //cs +//struct gf_marker *gfp; +extern struct gf_marker *gfp; //cs +//inst ipc; +extern inst ipc; //cs +//word *sp = NULL; +extern word *sp; //cs + +//int ilevel; +extern int ilevel; //cs +//struct descrip value_tmp; +extern struct descrip value_tmp; //cs +//struct descrip eret_tmp; +extern struct descrip eret_tmp; //cs + +//int coexp_act; +extern int coexp_act; //cs + +//#line 40 "interp.r" + +//dptr xargp; +extern dptr xargp; //cs +//word xnargs; +extern word xnargs; //cs + +//#line 155 "interp.r" + +//int interp(fsig, cargp) +//int fsig; +//dptr cargp; +static int icall(dptr procptr, dptr arglistptr, dptr result) //cs + { + register word opnd; + register word *rsp; + register dptr rargp; + register struct ef_marker *newefp; + register struct gf_marker *newgfp; + register word *wd; + register word *firstwd, *lastwd; + word *oldsp; + int type, signal, args; +// extern int (*optab[])(); + extern int (*optab[])(dptr); //cs +// extern int (*keytab[])(); + extern int (*keytab[])(dptr); //cs + struct b_proc *bproc; + dptr lval; //cs + int fsig = 0; //cs + dptr cargp = (dptr)(sp+1); //cs + dptr return_cargp = cargp; //cs + word *saved_sp = sp; //cs + word *return_sp = sp + 2; //cs + + cargp[0] = *procptr; //cs + cargp[1] = *arglistptr; //cs + sp += 4; //cs + +//#line 189 "interp.r" + + if (BlkLoc(k_current) == BlkLoc(k_main) && + ((char *)sp + PerilDelta) > (char *)stackend) + fatalerr(301, NULL); + +//#line 195 "interp.r" + +#if GPX //cs + if (!pollctr--) { + pollctr = pollevent(); + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 201 "interp.r" + + ilevel++; + + rsp = sp;; + +//#line 215 "interp.r" + + if (fsig == G_Csusp) { + +//#line 218 "interp.r" + + oldsp = rsp; + +//#line 223 "interp.r" + + newgfp = (struct gf_marker *)(rsp + 1); + newgfp->gf_gentype = fsig; + newgfp->gf_gfp = gfp; + newgfp->gf_efp = efp; + newgfp->gf_ipc = ipc; + rsp += ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + +//#line 235 "interp.r" + + if (gfp != 0) { + if (gfp->gf_gentype == G_Psusp) + firstwd = (word *)gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)gfp + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)cargp + 1; + +//#line 249 "interp.r" + + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + gfp = newgfp; + } + +//#line 257 "interp.r" + + goto apply; //cs + + for (; ; ) { + +//#line 330 "interp.r" + + lastop = (word)(*ipc.op++); + + if( rsp < return_sp ) //cs + syserror("loadfuncpp: call of Icon from C++ must return a value, yet failed instead"); + +//#line 348 "interp.r" + + switch ((int)lastop) { + +//#line 359 "interp.r" + + case 51: + ipc.op[-1] = (90); + PushValSP(rsp, D_Cset); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + ipc.opnd[-1] = (opnd); + PushValSP(rsp, opnd); + break; + + case 90: + PushValSP(rsp, D_Cset); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 60: + PushValSP(rsp, D_Integer); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 75: + ipc.op[-1] = (91); + PushValSP(rsp, D_Real); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + PushValSP(rsp, opnd); + ipc.opnd[-1] = (opnd); + break; + + case 91: + PushValSP(rsp, D_Real); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 77: + ipc.op[-1] = (92); + PushValSP(rsp, (*ipc.opnd++)); + opnd = (word)strcons + (*ipc.opnd++); + ipc.opnd[-1] = (opnd); + PushValSP(rsp, opnd); + break; + + case 92: + PushValSP(rsp, (*ipc.opnd++)); + PushValSP(rsp, (*ipc.opnd++)); + break; + +//#line 407 "interp.r" + + case 81: + PushValSP(rsp, D_Var); + PushValSP(rsp, &glbl_argp[(*ipc.opnd++) + 1]); + break; + + case 84: + ipc.op[-1] = (93); + PushValSP(rsp, D_Var); + opnd = (*ipc.opnd++); + PushValSP(rsp, &globals[opnd]); + ipc.opnd[-1] = ((word)&globals[opnd]); + break; + + case 93: + PushValSP(rsp, D_Var); + PushValSP(rsp, (*ipc.opnd++)); + break; + + case 83: + PushValSP(rsp, D_Var); + PushValSP(rsp, &pfp->pf_locals[(*ipc.opnd++)]); + break; + + case 82: + ipc.op[-1] = (94); + PushValSP(rsp, D_Var); + opnd = (*ipc.opnd++); + PushValSP(rsp, &statics[opnd]); + ipc.opnd[-1] = ((word)&statics[opnd]); + break; + + case 94: + PushValSP(rsp, D_Var); + PushValSP(rsp, (*ipc.opnd++)); + break; + +//#line 448 "interp.r" + + case 4: + case 19: + case 23: + case 34: + case 37: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 453 "interp.r" + + ; + Deref(rargp[1]); + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 455 "interp.r" + + ; + + case 43: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 458 "interp.r" + + ; + Deref(rargp[1]); + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 460 "interp.r" + + ; + + case 21: + case 22: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 464 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 465 "interp.r" + + ; + + case 32: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 474 "interp.r" + + case 40: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 475 "interp.r" + + ; + Deref(rargp[1]); + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 477 "interp.r" + + ; + + case 2: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 481 "interp.r" + + ; + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 482 "interp.r" + + ; + +//#line 486 "interp.r" + + case 3: + case 5: + case 6: + case 8: + case 9: + case 16: + case 17: + case 18: + case 31: + case 42: + case 30: + case 7: + case 10: + case 11: + case 12: + case 13: + case 14: + case 15: + case 20: + case 24: + case 25: + case 26: + case 27: + case 29: + case 28: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 511 "interp.r" + + ; + Deref(rargp[1]); + Deref(rargp[2]); + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 514 "interp.r" + + ; + + case 1: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 517 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 518 "interp.r" + + ; + + case 39: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 522 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 523 "interp.r" + + ; + + case 38: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 527 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 528 "interp.r" + + ; + +//#line 531 "interp.r" + + case 33: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 532 "interp.r" + + ; + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 533 "interp.r" + + ; + + case 35: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 537 "interp.r" + + ; + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 538 "interp.r" + + ; + +//#line 542 "interp.r" + + case 36: + PushNullSP(rsp); + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 4; + xargp = rargp; + sp = rsp;; + +//#line 544 "interp.r" + + ; + +//#line 85 "interp.r" + + if ((*(optab[lastop]))(rargp) == A_Resume) { + +//#line 89 "interp.r" + + goto efail_noev; + } + rsp = (word *)rargp + 1; + +//#line 95 "interp.r" + + break; + +//#line 545 "interp.r" + + ; + +//#line 548 "interp.r" + + case 41: + +//#line 65 "interp.r" + + rargp = (dptr)(rsp - 1) - 3; + xargp = rargp; + sp = rsp;; + +//#line 549 "interp.r" + + ; + Deref(rargp[1]); + Deref(rargp[2]); + Deref(rargp[3]); + +//#line 105 "interp.r" + + signal = (*(optab[lastop]))(rargp); + goto C_rtn_term; + +//#line 553 "interp.r" + + ; + + case 98: + +//#line 559 "interp.r" + +#if GPX //cs + if (!pollctr--) { + sp = rsp;; + pollctr = pollevent(); + rsp = sp;; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 570 "interp.r" + + break; + +//#line 573 "interp.r" + + case 108: + { + +//#line 583 "interp.r" + + break; + } + + case 64: + +//#line 590 "interp.r" + +#if GPX //cs + if (!pollctr--) { + sp = rsp;; + pollctr = pollevent(); + rsp = sp;; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 606 "interp.r" + + break; + +//#line 610 "interp.r" + + case 44: + PushDescSP(rsp, k_subject); + PushValSP(rsp, D_Integer); + PushValSP(rsp, k_pos); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 614 "interp.r" + + ; + + signal = Obscan(2, rargp); + + goto C_rtn_term; + + case 55: + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 1; + xargp = rargp; + sp = rsp;; + +//#line 621 "interp.r" + + ; + + signal = Oescan(1, rargp); + + goto C_rtn_term; + +//#line 629 "interp.r" + + case 89: { + apply: //cs + union block *bp; + int i, j; + + value_tmp = *(dptr)(rsp - 1); + Deref(value_tmp); + switch (Type(value_tmp)) { + case T_List: { + rsp -= 2; + bp = BlkLoc(value_tmp); + args = (int)bp->list.size; + +//#line 647 "interp.r" + + if (BlkLoc(k_current) == BlkLoc(k_main) && + ((char *)sp + args * sizeof(struct descrip) > + (char *)stackend)) + fatalerr(301, NULL); + +//#line 653 "interp.r" + + for (bp = bp->list.listhead; + +//#line 657 "interp.r" + + bp != NULL; + + bp = bp->lelem.listnext) { + for (i = 0; i < bp->lelem.nused; i++) { + j = bp->lelem.first + i; + if (j >= bp->lelem.nslots) + j -= bp->lelem.nslots; + PushDescSP(rsp, bp->lelem.lslots[j]); + } + } + goto invokej; + } + + case T_Record: { + rsp -= 2; + bp = BlkLoc(value_tmp); + args = bp->record.recdesc->proc.nfields; + for (i = 0; i < args; i++) { + PushDescSP(rsp, bp->record.fields[i]); + } + goto invokej; + } + + default: { + + xargp = (dptr)(rsp - 3); + err_msg(126, &value_tmp); + goto efail; + } + } + } + + case 61: { + args = (int)(*ipc.opnd++); + invokej: + { + int nargs; + dptr carg; + + sp = rsp;; + type = invoke(args, &carg, &nargs); + rsp = sp;; + + if (type == I_Fail) + goto efail_noev; + if (type == I_Continue) + break; + else { + + rargp = carg; + +//#line 712 "interp.r" + +#if GPX //cs + pollctr >>= 1; + if (!pollctr) { + sp = rsp;; + pollctr = pollevent(); + rsp = sp;; + if (pollctr == -1) fatalerr(141, NULL); + } +#endif + +//#line 726 "interp.r" + + bproc = (struct b_proc *)BlkLoc(*rargp); + +//#line 734 "interp.r" + + if (type == I_Vararg) { +// int (*bfunc)(); + int (*bfunc)(int, dptr); //cs +// bfunc = bproc->entryp.ccode; + bfunc = (int (*)(int,dptr))(bproc->entryp.ccode); + +//#line 741 "interp.r" + + signal = (*bfunc)(nargs, rargp); + } + else + +//#line 746 "interp.r" + + { +// int (*bfunc)(); + int (*bfunc)(dptr); +// bfunc = bproc->entryp.ccode; + bfunc = (int (*)(dptr))(bproc->entryp.ccode); + +//#line 753 "interp.r" + + signal = (*bfunc)(rargp); + } + +//#line 767 "interp.r" + + goto C_rtn_term; + } + } + } + + case 62: + + PushNullSP(rsp); + opnd = (*ipc.opnd++); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 0; + xargp = rargp; + sp = rsp;; + +//#line 776 "interp.r" + + ; + + signal = (*(keytab[(int)opnd]))(rargp); + goto C_rtn_term; + + case 65: + opnd = (*ipc.opnd++); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - opnd; + xargp = rargp; + sp = rsp;; + +//#line 793 "interp.r" + + ; + +//#line 796 "interp.r" + + { + int i; + for (i = 1; i <= opnd; i++) + Deref(rargp[i]); + } + + signal = Ollist((int)opnd, rargp); + + goto C_rtn_term; + +//#line 808 "interp.r" + + case 67: + ipc.op[-1] = (96); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + ipc.opnd[-1] = (opnd); + newefp = (struct ef_marker *)(rsp + 1); + newefp->ef_failure.opnd = (word *)opnd; + goto mark; + + case 96: + newefp = (struct ef_marker *)(rsp + 1); + newefp->ef_failure.opnd = (word *)(*ipc.opnd++); + mark: + newefp->ef_gfp = gfp; + newefp->ef_efp = efp; + newefp->ef_ilevel = ilevel; + rsp += ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + efp = newefp; + gfp = 0; + break; + + case 85: + mark0: + newefp = (struct ef_marker *)(rsp + 1); + newefp->ef_failure.opnd = 0; + newefp->ef_gfp = gfp; + newefp->ef_efp = efp; + newefp->ef_ilevel = ilevel; + rsp += ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + efp = newefp; + gfp = 0; + break; + + case 78: + +//#line 849 "interp.r" + + gfp = efp->ef_gfp; + rsp = (word *)efp - 1; + +//#line 855 "interp.r" + + Unmark_uw: + if (efp->ef_ilevel < ilevel) { + --ilevel; + + sp = rsp;; + +//#line 866 "interp.r" + + return A_Unmark_uw; + } + + efp = efp->ef_efp; + break; + +//#line 874 "interp.r" + + case 56: { + +//#line 879 "interp.r" + + oldsp = rsp; + newgfp = (struct gf_marker *)(rsp + 1); + newgfp->gf_gentype = G_Esusp; + newgfp->gf_gfp = gfp; + newgfp->gf_efp = efp; + newgfp->gf_ipc = ipc; + gfp = newgfp; + rsp += ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + +//#line 892 "interp.r" + + if (efp->ef_gfp != 0) { + newgfp = (struct gf_marker *)(efp->ef_gfp); + if (newgfp->gf_gentype == G_Psusp) + firstwd = (word *)efp->ef_gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)efp->ef_gfp + + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)efp->ef_efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)efp - 1; + efp = efp->ef_efp; + +//#line 909 "interp.r" + + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + PushValSP(rsp, oldsp[-1]); + PushValSP(rsp, oldsp[0]); + break; + } + + case 66: { + struct descrip sval; + +//#line 924 "interp.r" + +// dptr lval = (dptr)((word *)efp - 2); + lval = (dptr)((word *)efp - 2); //cs + +//#line 929 "interp.r" + + if (--IntVal(*lval) > 0) { + +//#line 934 "interp.r" + + sval = *(dptr)(rsp - 1); + +//#line 941 "interp.r" + + if (efp->ef_gfp != 0) { + newgfp = (struct gf_marker *)(efp->ef_gfp); + if (newgfp->gf_gentype == G_Psusp) + firstwd = (word *)efp->ef_gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)efp->ef_gfp + + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)efp->ef_efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)efp - 3; + if (gfp == 0) + gfp = efp->ef_gfp; + efp = efp->ef_efp; + +//#line 960 "interp.r" + + rsp -= 2; + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + PushDescSP(rsp, sval); + } + else { + +//#line 973 "interp.r" + + *lval = *(dptr)(rsp - 1); + +//#line 981 "interp.r" + + gfp = efp->ef_gfp; + +//#line 987 "interp.r" + + Lsusp_uw: + if (efp->ef_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 997 "interp.r" + + return A_Lsusp_uw; + } + rsp = (word *)efp - 1; + efp = efp->ef_efp; + } + break; + } + + case 72: { + +//#line 1015 "interp.r" + + struct descrip tmp; + dptr svalp; + struct b_proc *sproc; + +//#line 1025 "interp.r" + + svalp = (dptr)(rsp - 1); + if (Var(*svalp)) { + sp = rsp;; + retderef(svalp, (word *)glbl_argp, sp); + rsp = sp;; + } + +//#line 1035 "interp.r" + + oldsp = rsp; + newgfp = (struct gf_marker *)(rsp + 1); + newgfp->gf_gentype = G_Psusp; + newgfp->gf_gfp = gfp; + newgfp->gf_efp = efp; + newgfp->gf_ipc = ipc; + newgfp->gf_argp = glbl_argp; + newgfp->gf_pfp = pfp; + gfp = newgfp; + rsp += ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + +//#line 1051 "interp.r" + + if (pfp->pf_gfp != 0) { + newgfp = (struct gf_marker *)(pfp->pf_gfp); + if (newgfp->gf_gentype == G_Psusp) + firstwd = (word *)pfp->pf_gfp + ((sizeof((*gfp)) + sizeof(word) - 1) / sizeof(word)); + else + firstwd = (word *)pfp->pf_gfp + + ((sizeof(struct gf_smallmarker) + sizeof(word) - 1) / sizeof(word)); + } + else + firstwd = (word *)pfp->pf_efp + ((sizeof((*efp)) + sizeof(word) - 1) / sizeof(word)); + lastwd = (word *)glbl_argp - 1; + efp = efp->ef_efp; + +//#line 1068 "interp.r" + + for (wd = firstwd; wd <= lastwd; wd++) + *++rsp = *wd; + PushValSP(rsp, oldsp[-1]); + PushValSP(rsp, oldsp[0]); + --k_level; + if (k_trace) { + k_trace--; + sproc = (struct b_proc *)BlkLoc(*glbl_argp); + strace(&(sproc->pname), svalp); + } + +//#line 1083 "interp.r" + + if (pfp->pf_scan != NULL) { + +//#line 1089 "interp.r" + + tmp = k_subject; + k_subject = *pfp->pf_scan; + *pfp->pf_scan = tmp; + + tmp = *(pfp->pf_scan + 1); + IntVal(*(pfp->pf_scan + 1)) = k_pos; + k_pos = IntVal(tmp); + } + +//#line 1106 "interp.r" + + efp = pfp->pf_efp; + ipc = pfp->pf_ipc; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + break; + } + +//#line 1115 "interp.r" + + case 54: { + +//#line 1124 "interp.r" + + eret_tmp = *(dptr)&rsp[-1]; + gfp = efp->ef_gfp; + Eret_uw: + +//#line 1131 "interp.r" + + if (efp->ef_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 1140 "interp.r" + + return A_Eret_uw; + } + rsp = (word *)efp - 1; + efp = efp->ef_efp; + PushDescSP(rsp, eret_tmp); + break; + } + +//#line 1149 "interp.r" + + case 71: { + +//#line 1163 "interp.r" + + struct b_proc *rproc; + rproc = (struct b_proc *)BlkLoc(*glbl_argp); + +//#line 1173 "interp.r" + + *glbl_argp = *(dptr)(rsp - 1); + if (Var(*glbl_argp)) { + sp = rsp;; + retderef(glbl_argp, (word *)glbl_argp, sp); + rsp = sp;; + } + + --k_level; + if (k_trace) { + k_trace--; + rtrace(&(rproc->pname), glbl_argp); + } + Pret_uw: + if (pfp->pf_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 1196 "interp.r" + + return A_Pret_uw; + } + +//#line 1203 "interp.r" + + rsp = (word *)glbl_argp + 1; + efp = pfp->pf_efp; + gfp = pfp->pf_gfp; + ipc = pfp->pf_ipc; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + +//#line 1219 "interp.r" + +//cs return to C++ + if( rsp == return_sp ) { + //printf("Op_Pret caused a return to C++\n");fflush(stdout); + --ilevel; + *result = *return_cargp; + sp = saved_sp; + return 0; + } +//cs end return to C++ + break; + } + +//#line 1224 "interp.r" + + case 53: + efail: + +//#line 1229 "interp.r" + + efail_noev: + +//#line 1233 "interp.r" + + if (gfp == 0) { + +//#line 1251 "interp.r" + + ipc = efp->ef_failure; + gfp = efp->ef_gfp; + rsp = (word *)efp - 1; + efp = efp->ef_efp; + + if (ipc.op == 0) + goto efail; + break; + } + else + { + +//#line 1267 "interp.r" + + struct descrip tmp; + register struct gf_marker *resgfp = gfp; + + type = (int)resgfp->gf_gentype; + + if (type == G_Psusp) { + glbl_argp = resgfp->gf_argp; + if (k_trace) { + k_trace--; + sp = rsp;; + atrace(&(((struct b_proc *)BlkLoc(*glbl_argp))->pname)); + rsp = sp;; + } + } + ipc = resgfp->gf_ipc; + efp = resgfp->gf_efp; + gfp = resgfp->gf_gfp; + rsp = (word *)resgfp - 1; + if (type == G_Psusp) { + pfp = resgfp->gf_pfp; + +//#line 1292 "interp.r" + + if (pfp->pf_scan != NULL) { + tmp = k_subject; + k_subject = *pfp->pf_scan; + *pfp->pf_scan = tmp; + + tmp = *(pfp->pf_scan + 1); + IntVal(*(pfp->pf_scan + 1)) = k_pos; + k_pos = IntVal(tmp); + } + +//#line 1313 "interp.r" + + ++k_level; + } + + switch (type) { + +//#line 1336 "interp.r" + + case G_Csusp: + ; + --ilevel; + sp = rsp;; + +//#line 1344 "interp.r" + + return A_Resume; + + case G_Esusp: + ; + goto efail_noev; + + case G_Psusp: + ; + break; + } + + break; + } + + case 68: { + +//#line 1374 "interp.r" + + --k_level; + if (k_trace) { + k_trace--; + failtrace(&(((struct b_proc *)BlkLoc(*glbl_argp))->pname)); + } + Pfail_uw: + + if (pfp->pf_ilevel < ilevel) { + --ilevel; + sp = rsp;; + +//#line 1388 "interp.r" + + return A_Pfail_uw; + } + efp = pfp->pf_efp; + gfp = pfp->pf_gfp; + ipc = pfp->pf_ipc; + glbl_argp = pfp->pf_argp; + pfp = pfp->pf_pfp; + +//#line 1406 "interp.r" + + goto efail_noev; + } + +//#line 1410 "interp.r" + + case 45: + PushNullSP(rsp); + PushValSP(rsp, ((word *)efp)[-2]); + PushValSP(rsp, ((word *)efp)[-1]); + break; + + case 46: + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + efp->ef_failure.opnd = (word *)opnd; + break; + + case 52: + PushNullSP(rsp); + rsp[1] = rsp[-3]; + rsp[2] = rsp[-2]; + rsp += 2; + break; + + case 57: + PushValSP(rsp, D_Integer); + PushValSP(rsp, (*ipc.opnd++)); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 2; + xargp = rargp; + sp = rsp;; + +//#line 1432 "interp.r" + + ; + + signal = Ofield(2, rargp); + + goto C_rtn_term; + + case 58: + ipc.op[-1] = (95); + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + ipc.opnd[-1] = (opnd); + ipc.opnd = (word *)opnd; + break; + + case 95: + opnd = (*ipc.opnd++); + ipc.opnd = (word *)opnd; + break; + + case 59: + *--ipc.op = 58; + opnd = sizeof((*ipc.op)) + sizeof((*rsp)); + opnd += (word)ipc.opnd; + ipc.opnd = (word *)opnd; + break; + + case 63: + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 0; + xargp = rargp; + sp = rsp;; + +//#line 1459 "interp.r" + + ; + + if (Olimit(0, rargp) == A_Resume) { + +//#line 1468 "interp.r" + + goto efail_noev; + } + else { + +//#line 1476 "interp.r" + + rsp = (word *)rargp + 1; + } + goto mark0; + +//#line 1486 "interp.r" + + case 69: + PushNullSP(rsp); + break; + + case 70: + rsp -= 2; + break; + + case 73: + PushValSP(rsp, D_Integer); + PushValSP(rsp, 1); + break; + + case 74: + PushValSP(rsp, D_Integer); + PushValSP(rsp, -1); + break; + + case 76: + rsp += 2; + rsp[-1] = rsp[-3]; + rsp[0] = rsp[-2]; + break; + +//#line 1512 "interp.r" + + case 50: + +//#line 1515 "interp.r" + + PushNullSP(rsp); + +//#line 79 "interp.r" + + rargp = (dptr)(rsp - 1) - 0; + xargp = rargp; + sp = rsp;; + +//#line 1516 "interp.r" + + ; + opnd = (*ipc.opnd++); + opnd += (word)ipc.opnd; + + signal = Ocreate((word *)opnd, rargp); + + goto C_rtn_term; + +//#line 1528 "interp.r" + + case 47: { + +//#line 1534 "interp.r" + + struct b_coexpr *ncp; + dptr dp; + + sp = rsp;; + dp = (dptr)(sp - 1); + xargp = dp - 2; + + Deref(*dp); + if (dp->dword != D_Coexpr) { + err_msg(118, dp); + goto efail; + } + + ncp = (struct b_coexpr *)BlkLoc(*dp); + + signal = activate((dptr)(sp - 3), ncp, (dptr)(sp - 3)); + rsp = sp;; + if (signal == A_Resume) + goto efail_noev; + else + rsp -= 2; + + break; + } + + case 49: { + +//#line 1564 "interp.r" + + struct b_coexpr *ncp; + + sp = rsp;; + ncp = popact((struct b_coexpr *)BlkLoc(k_current)); + + ++BlkLoc(k_current)->coexpr.size; + co_chng(ncp, (dptr)&sp[-1], NULL, A_Coret, 1); + rsp = sp;; + + break; + } + +//#line 1577 "interp.r" + + case 48: { + +//#line 1582 "interp.r" + + struct b_coexpr *ncp; + + sp = rsp;; + ncp = popact((struct b_coexpr *)BlkLoc(k_current)); + + co_chng(ncp, NULL, NULL, A_Cofail, 1); + rsp = sp;; + + break; + } + + case 86: + +//#line 1596 "interp.r" + + goto interp_quit; + +//#line 1599 "interp.r" + + default: { + char buf[50]; + + sprintf(buf, "unimplemented opcode: %ld (0x%08x)\n", + (long)lastop, lastop); + syserr(buf); + } + } + continue; + + C_rtn_term: + rsp = sp;; + + switch (signal) { + + case A_Resume: + +//#line 1622 "interp.r" + + goto efail_noev; + + case A_Unmark_uw: + +//#line 1631 "interp.r" + + goto Unmark_uw; + + case A_Lsusp_uw: + +//#line 1640 "interp.r" + + goto Lsusp_uw; + + case A_Eret_uw: + +//#line 1649 "interp.r" + + goto Eret_uw; + + case A_Pret_uw: + +//#line 1658 "interp.r" + + goto Pret_uw; + + case A_Pfail_uw: + +//#line 1667 "interp.r" + + goto Pfail_uw; + } + + rsp = (word *)rargp + 1; + +//#line 1682 "interp.r" + + continue; + } + + interp_quit: + --ilevel; + if (ilevel != 0) + syserror("interp: termination with inactive generators."); + + return 0; + } + +} //cs --- extern "C" diff --git a/ipl/procs/calls.icn b/ipl/procs/calls.icn index 6ebb8a1..00f6114 100644 --- a/ipl/procs/calls.icn +++ b/ipl/procs/calls.icn @@ -6,7 +6,7 @@ # # Author: Ralph E. Griswold # -# Date: March 25, 2002 +# Date: March 6, 2008 # ############################################################################ # @@ -137,7 +137,7 @@ procedure read_calltable(f) T := table() - every line := read(f) do + while line := read(f) do line ? { name := tab(upto('="')) | fail move(1) diff --git a/ipl/procs/echo.icn b/ipl/procs/echo.icn new file mode 100644 index 0000000..5a90c97 --- /dev/null +++ b/ipl/procs/echo.icn @@ -0,0 +1,227 @@ +############################################################################ +# +# File: echo.icn +# +# Subject: Procedure to perform "variable interpolation" a la Perl +# +# Authors: Charles L Hethcoat III and Carl Sturtivant +# +# Date: February 9, 2010 +# +############################################################################ +# +# This file is in the public domain. +# +############################################################################ +# +# echo() substitutes global variables for occurrences of $name in &subject, +# and writes the result to standard output. +# +############################################################################ +# +# Background: +# +# String "interpolation", as used in Perl, Tcl, Bash, and so on, +# involves a special notation used within a string that causes the +# value of a variable to be inserted into the string at runtime. A +# common notation for this is a dollar sign, e. g. "The price is +# $price pfennig." If a variable named "price" has the value 10, then +# on output the string becomes "The price is 10 pfennig." +# +# Interpolation is lacking in Icon, so we must use the fussier syntax +# of an Icon write() procedure: write("The price is ", price, +# "pfennig."). Here is a slightly more complex example, assuming +# variables `price' = 10, `article' == "thimble", and `currency' == +# "pfennig": +# +# write("The price of a ", article, " is ", price, " ", currency, ".") +# +# This can be annoying and error-prone if we must use many such +# strings in a program. +# +# The echo() procedure provides a very nice solution for Icon +# programmers. Compare the preceding write() call to this: +# +# "The price of a $article is $price $currency" ? echo() +# +# Is this not much simpler? Both examples will print out the string +# +# "The price of a thimble is 10 pfennig." +# +# but interpolation with echo() greatly reduces the low-level +# syntactic requirements (and reduces the number of characters to type +# from 68 to 54). It is much easier to write, read, and check. If +# many such lines of code are needed, the difference adds up. +# Consider, for example, how this would pay off if your program needs +# to generate hundreds of lines of HTML or PostScript. +# +############################################################################ +# +# Usage: +# +# A string to +# be printed with interpolated values should be set up in a scanning +# environment, using echo() as the scanning procedure, as in +# "foo$variable" ? echo(). Here is an actual example for testing: +# +# link echo +# global month, day, year +# +# procedure main() +# month := "February" +# day := 30 +# year := 2010 +# "Free beer on $month $day, $year." ? echo() +# end +# +# Assuming echo.icn has been compiled with the -c option beforehand, +# compiling, linking, and running this program produces the string +# "Free beer on February 30, 2010." on standard output. +# +############################################################################ +# +# Notes: +# +# Since there is no way for any Icon procedure to discover the values of +# any another procedure's local variables, all variables to be used via +# the echo() procedure must be global. This restriction ought not to be +# too serious for smaller programs, or even longer ones if they are of +# simple construction. But it may be a limitation for sophisticated +# Icon programming projects. You will have to be the judge. +# +# If x is a global variable with value 10, +# +# "x" ? echo() prints "x" +# "$x" ? echo() prints "10" +# "$$x" ? echo() prints "$x" +# "$$$x" ? echo() prints "$10" +# "$$$$x" ? echo() prints "$$x" +# "$$$$$x" ? echo() prints "$$10" +# +# and so on. The rule is: take dollar signs off in pairs from the +# left. Each pair prints ONE literal dollar sign on the output. +# +# If there were an odd number of dollar signs to begin with, then one +# will be left over, and this will print the value of the variable (10). +# +# If there were an even number to begin with, then none are left, and a +# literal "x" is printed. +# +# There is an extended notation that helps disambiguate some usage +# scenarios. Here are some examples: +# +# "${x}" is the same as $x. +# "${x}:" is the same as $x:. +# "${x}${y}" is the same as $x$y. +# +# However, "${x}avier" is NOT the same as $xavier! Can you see why? +# +# You may use any variable names you like. There are no restrictions. +# echo() uses no global variable names of its own, but receives the +# string it interpolates in a string scanning environment. +# +############################################################################ +# +# Using echo() on a larger scale , with input from a generator: +# +# global time, date, save, wombats +# +# link echo +# +# procedure main() +# time := &clock +# date := &date +# save := ?100000 +# wombats := 22 +# "It is now $time on $date and you have savings of $$$save." | +# "The number of wombats is $wombats." | +# "It is now ${time} on ${date} and you have ${wombats} wombats." | +# "There is no global variable named \"$foo\"." | +# "This does not work: It is now ${&clock}." | +# "" | +# "The previous input line printed an empty output line." ? echo() +# end +# +# Because echo() always fails (in the Icon sense), evaluation of +# +# a | b | c | d ? echo() +# +# will group as +# +# (a | b | c | d) ? echo() +# +# because of operator precedence, and the left-hand expression produces +# _a_ first, which is assigned to &subject. Then echo() is evaluated -- +# and fails. This makes the whole expression fail, so Icon backtracks +# to the first expression, resumes its evaluation to produce its second +# value b, which is assigned to &subject and then echo() is called, +# which fails, and so forth, until all possibilities are exhausted. +# +############################################################################ +# +# Taking input from a template file: +# +# You can create a template file (with $-strings in it) and use an Icon +# program to read it and write it out to standard output. Your main +# Icon program will supply the needed variable values for the $-strings +# in the template. +# +# As an example, suppose your program will generate a hundred business +# cards for you as a PostScript file. You have a template file named +# template.ps with $-strings such as $firstname, $lastname, $address, +# $companyname, and so on --- all embedded in it at the proper places. +# Your main program will read this template and substitute the actual +# name and address information. +# +# This is one way your program can read template.ps and pass it to +# echo(): +# +# ... +# firstname := "Joe" +# lastname := "Smith" +# # ... etc. ... +# reads("template.ps",1000000) ? echo() +# ... +# +# When this is run, your customized business cards appear on standard +# output. +# +############################################################################ +# +# This trick relies upon concatenation having a higher precedence +# than alternation: +# +# "................" || +# "................" || +# "................" | +# "................" || +# "................" | +# "................" || +# "................" ? echo() +# +# This prints out three messages, one specified on three lines, one on +# two, and one on two. The alternations fix the newlines provided at the +# end of each message by echo(). +# +# &subject is the empty string if it's unassigned. So echo() called +# without ? will under those circumstances print a blank line. +# +############################################################################ + +procedure echo() #: interpolate variables and print + + $define idchars 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789_' + while writes(tab(find("$")) ) do { + move(1) + writes( ="$" | + variable(tab(many(idchars)) | + 2( ="{", tab(find("}")), ="}" ) + ) + ) | + tab(many(idchars)) | + ( ="{" & tab(find("}")) & ="}" ) + } + write(tab(0)) + $undef idchars + +end diff --git a/ipl/procs/printf.icn b/ipl/procs/printf.icn index b5f99b9..b264692 100644 --- a/ipl/procs/printf.icn +++ b/ipl/procs/printf.icn @@ -6,7 +6,7 @@ # # Author: William H. Mitchell # -# Date: July 20, 2005 +# Date: February 13, 2006 # ############################################################################ # @@ -14,30 +14,19 @@ # ############################################################################ # -# Contributors: Cheyenne Wills, Phillip Lee Thomas, Michael Glass +# Contributors: Cheyenne Wills, Phillip Lee Thomas, +# Michael Glass, Gregg M. Townsend # ############################################################################ # # This procedure behaves somewhat like the standard printf. # Supports d, e, s, o, and x formats like printf. An "r" format -# prints real numbers in a manner similar to that of printf's "f", -# but will produce a result in an exponential format if the number -# is larger than the largest integer plus one. Though "e" differs -# from printf in some details, it always produces exponential format. +# prints real numbers in a manner similar to that of printf's "f". +# Though "e" differs from printf in some details, it always produces +# exponential format. # -# Left or right justification and field width control are pro- -# vided as in printf. %s, %r, and %e handle precision specifications. -# -# The %r format is quite a bit of a hack, but it meets the -# author's requirements for accuracy and speed. Code contributions -# for %f, %e, and %g formats that work like printf are welcome. -# -# Possible new formats: -# -# %t -- print a real number as a time in hh:mm -# %R -- roman numerals -# %w -- integers in English -# %b -- binary +# Left or right justification and field width control are provided +# as in printf. %s, %r, and %e handle precision specifications. # ############################################################################ @@ -100,86 +89,52 @@ procedure _doprnt(format, args) end procedure hexstr(n) - local h, neg - static BigNeg, hexdigs, hexfix - - initial { - BigNeg := -2147483647-1 - hexdigs := "0123456789abcdef" - hexfix := "89abcdef" - } - - n := integer(n) - if n = BigNeg then - return "80000000" - h := "" - if n < 0 then { - n := -(BigNeg - n) - neg := 1 - } - repeat { - h := hexdigs[n%16+1]||h - if (n /:= 16) = 0 then - break - } - if \neg then { - h := right(h,8,"0") - h[1] := hexfix[h[1]+1] - } - return h + return _basestr(n, 4) end + procedure octstr(n) - local h, neg - static BigNeg, octdigs, octfix + return _basestr(n, 3) +end - initial { - BigNeg := -2147483647-1 - octdigs := "01234567" - octfix := "23" - } +procedure _basestr(n, b) + local s, mask - n := integer(n) - if n = BigNeg then - return "20000000000" - h := "" - if n < 0 then { - n := -(BigNeg - n) - neg := 1 - } - repeat { - h := octdigs[n%8+1]||h - if (n /:= 8) = 0 then - break - } - if \neg then { - h := right(h,11,"0") - h[1] := octfix[h[1]+1] + n := integer(n) | return image(n) + + if n = 0 then + return "0" + + # backwards compatibility hack + # treat 31-bit negative integers as positive values + if -16r80000000 <= n <= -1 then + n +:= 16r100000000 + + s := "" + mask := ishift(1, b) - 1 + while n ~= 0 & n ~= -1 do { + s := "0123456789abcdef" [1 + iand(n, mask)] || s + n := ishift(n, -b) } - return h + return s end procedure fixnum(x, prec) - local int, frac, f1, f2, p10 + local s /prec := 6 x := real(x) | return image(x) - int := integer(x) | return image(x) - frac := image(x - int) - if find("e", frac) then { - frac ?:= { - f1 := tab(upto('.')) & - move(1) & - f2 := tab(upto('e')) & - move(1) & - p10 := -integer(tab(0)) & - repl("0",p10-1) || f1 || f2 - } - } + + if x < 0 then { + s := "-" + x := -x + } else - frac ?:= (tab(upto('.')) & move(1) & tab(0)) - frac := adjustfracprec(frac, prec) - int +:= if int >= 0 then frac[2] else -frac[2] - return int || "." || frac[1] + s := "" + + x := string(integer(x * 10 ^ prec + 0.5)) + if *x <= prec then + x := right(x, prec + 1, "0") + return s || x[1:-prec] || "." || x[-prec:0] end @@ -302,10 +257,10 @@ procedure adjustfracprec(fracpart, prec) carryout := 1 } # In the usual case, round up simply increments the - # fractional part. (We put back any trailing + # fractional part. (We put back any leading # zeros that got lost.) else { - fracpart := left(integer(fracpart)+1, prec, "0") + fracpart := right(integer(fracpart)+1, prec, "0") } } } diff --git a/ipl/procs/random.icn b/ipl/procs/random.icn index 8dc58f2..2749bb7 100644 --- a/ipl/procs/random.icn +++ b/ipl/procs/random.icn @@ -6,7 +6,7 @@ # # Authors: Ralph E. Griswold and Gregg M. Townsend # -# Date: June 24, 2002 +# Date: November 5, 2009 # ############################################################################ # @@ -87,18 +87,19 @@ procedure rand_int(i) #: model ?i end procedure randomize() #: randomize - local f, s + local f, s, i static ncalls initial ncalls := 0 ncalls +:= 1 if f := open("/dev/urandom", "ru") then { - s := reads(f, 3) + s := reads(f, 4) close(f) if *\s > 0 then { - &random := ncalls % 113 - every &random := 256 * &random + ord(!s) + &random := 1 + every i := ord(!s) do + &random := 167 * &random + i return } } diff --git a/ipl/progs/diffsum.icn b/ipl/progs/diffsum.icn index 3414922..99c6e05 100644 --- a/ipl/progs/diffsum.icn +++ b/ipl/progs/diffsum.icn @@ -6,7 +6,7 @@ # # Author: Gregg M. Townsend # -# Date: May 31, 1994 +# Date: August 14, 2007 # ############################################################################ # @@ -26,7 +26,7 @@ # ############################################################################ -global oldname, newname +global oldname, newname, ixname, ixprev global added, deleted, chgadd, chgdel procedure main(args) @@ -42,9 +42,13 @@ procedure main(args) chgadd := chgdel := 0 while line := read(f) do line ? { - if =" " then + if any(' @') then next - else if ="***" then { + else if ="Index: " then { + ixprev := ixname + ixname := tab(0) + } + else if =("+++" | "***")then { chgadd := 0 chgdel := +1 } @@ -71,12 +75,15 @@ procedure main(args) else if ="Only " then only() } + ixprev := ixname report() end procedure report() local net + if oldname := \ixprev then + newname := "" if added > 0 | deleted > 0 then { net := string(added - deleted) if net > 0 then @@ -85,6 +92,7 @@ procedure report() } added := deleted := 0 chgadd := chgdel := 0 + ixprev := &null return end diff --git a/ipl/progs/hebeng.icn b/ipl/progs/hebeng.icn index 5dca84a..29b4c7f 100644 --- a/ipl/progs/hebeng.icn +++ b/ipl/progs/hebeng.icn @@ -38,7 +38,7 @@ # ############################################################################ -$ifdef _MACINTOSH +$ifdef _PROICON global outfilename, outvar, outwin,hebrew_string_flag, hebrew_text_flag, screenwidth,screenheight,markers @@ -290,7 +290,7 @@ local newline,substring return newline end -$else # not Macintosh +$else # not ProIcon procedure main() stop("sorry, ", &progname, " only runs under Macintosh ProIcon") end diff --git a/ipl/progs/lindsys.icn b/ipl/progs/lindsys.icn index bd92940..fcec498 100644 --- a/ipl/progs/lindsys.icn +++ b/ipl/progs/lindsys.icn @@ -6,7 +6,7 @@ # # Author: Ralph E. Griswold # -# Date: October 23, 1998 +# Date: May 10, 2006 # ############################################################################ # @@ -80,7 +80,7 @@ # Note: An earlier version of this program had the ability to # extract an L-System specification by name from a file with # multiple specifications. This version does not -- the former -# functionality was deemed to cumbersome. +# functionality was deemed too cumbersome. # # References: # diff --git a/ipl/progs/unclog.icn b/ipl/progs/unclog.icn index ec7fe41..9fc1e1e 100644 --- a/ipl/progs/unclog.icn +++ b/ipl/progs/unclog.icn @@ -6,7 +6,7 @@ # # Author: Gregg M. Townsend # -# Date: May 2, 2005 +# Date: August 14, 2007 # ############################################################################ # @@ -59,6 +59,7 @@ procedure main(args) # read description of modification while line := read(f) do { + if line ? ="branches:" then next if line ? =("-----------" | "===========") then break s ||:= "\n" || line } diff --git a/ipl/progs/weblinks.icn b/ipl/progs/weblinks.icn index b46fad5..8fd62c1 100644 --- a/ipl/progs/weblinks.icn +++ b/ipl/progs/weblinks.icn @@ -6,7 +6,7 @@ # # Author: Gregg M. Townsend # -# Date: September 27, 2001 +# Date: March 29, 2006 # ############################################################################ # @@ -63,6 +63,8 @@ # # -v report tracing and successes, if selected, more verbosely # +# -i invert output (sort by referencing page, not by status) +# # -r root # specify starting point for file names beginning with "/" # (e.g. -r /cs/www). This is needed if such references are @@ -120,7 +122,6 @@ # allow longer history persistence # history is clumsy -- hard to recheck a connection that failed # add option to retry failed entries (but believe cached successes) -# add option to sort report by referencing page $define URLCOLS 56 # number of columns allotted for tracing URLs @@ -137,6 +138,7 @@ global home global prune global bounds +global invert global recurse global trace global verbose @@ -166,7 +168,8 @@ procedure main(args) # process command line - opts := options(args, "b:p:r:h:Rstv") + opts := options(args, "b:p:r:h:iRstv") + invert := opts["i"] recurse := opts["R"] successes := opts["s"] trace := opts["t"] @@ -339,14 +342,29 @@ procedure check(url) end procedure report() - local l, url, stat + local l, url, stat, s, t, u l := sort(done, 4) + t := table() while (url := get(l)) & (stat := get(l)) do { if \successes | (any('3456789', stat) & stat ~== "302 Found") then { - write(pad(stat || ":", STATCOLS), " ", url) - if \verbose | any('3456789', stat) then - every write(" referenced by:\t", !sort(refto[url])) + s := pad(stat || ":", STATCOLS) || " " || url + if \invert then + every u := !refto[url] do + put(\t[u] | (t[u] := []), s) + else { + write(s) + if \verbose | any('3456789', stat) then + every write(" referenced by:\t", !sort(refto[url])) + } + } + } + + if \invert then { + l := sort(t, 3) + while (url := get(l)) & (stat := get(l)) do { + write(url) + every write(" ", !stat) } } diff --git a/man/man1/icon.1 b/man/man1/icon.1 index 1562816..785db3a 100644 --- a/man/man1/icon.1 +++ b/man/man1/icon.1 @@ -63,14 +63,19 @@ Normally, none of these are needed. the full-featured interface supporting separate compilation, multiple source files, and other features. .LP -.IR "The Icon Programming Language" . -Griswold and Griswold, -Peer-to-Peer, third edition, 1996. +\fIThe Icon Programming Language\fP. +.br +Griswold and Griswold, Peer-to-Peer, third edition, 1996. +.br +http://www.cs.arizona.edu/icon/lb3.htm. +.LP +\fIGraphics Programming in Icon\fP. +.br +Griswold, Jeffery, and Townsend, Peer-to-Peer, 1998. +.br +http://www.cs.arizona.edu/icon/gb/index.htm. .LP -.IR "Graphics Programming in Icon" . -Griswold, Jeffery, and Townsend, -Peer-to-Peer, 1998. .LP -.IR "Version 9.4.3 of Icon" . +.IR "Version 9.5.0 of Icon" . .br -http://www.cs.arizona.edu/icon/v943. +http://www.cs.arizona.edu/icon/v950. diff --git a/man/man1/icont.1 b/man/man1/icont.1 index c17a768..703d599 100644 --- a/man/man1/icont.1 +++ b/man/man1/icont.1 @@ -119,16 +119,20 @@ option. for embedding Icon programs in scripts. .LP \fIThe Icon Programming Language\fP. -Griswold and Griswold, -Peer-to-Peer, third edition, 1996. +.br +Griswold and Griswold, Peer-to-Peer, third edition, 1996. +.br +http://www.cs.arizona.edu/icon/lb3.htm. .LP \fIGraphics Programming in Icon\fP. -Griswold, Jeffery, and Townsend, -Peer-to-Peer, 1998. +.br +Griswold, Jeffery, and Townsend, Peer-to-Peer, 1998. +.br +http://www.cs.arizona.edu/icon/gb/index.htm. .LP -\fIVersion 9.4.3 of Icon\fP. +\fIVersion 9.5.0 of Icon\fP. .br -http://www.cs.arizona.edu/icon/v943. +http://www.cs.arizona.edu/icon/v950. .SH "CAVEATS" .LP Icon executables are not self-sufficient, but require the \fBiconx\fP diff --git a/src/Makefile b/src/Makefile index 2aaa971..7726ec3 100644 --- a/src/Makefile +++ b/src/Makefile @@ -5,14 +5,13 @@ what: @echo "What do you want to make?" Clean Pure: - cd iconc; rm -f *.o iconc - cd common; rm -f *.o doincl patchstr infer - cd preproc; rm -f *.o pp - cd rtt; rm -f *.o rtt - cd runtime; rm -f *.o *.c rt.db rt.a rttcur.lst rttfull.lst iconx - cd icont; rm -f *.o icont hdr.h ixhdr.hdr newhdr - cd wincap; rm -f *.o *.a - cd xpm; rm -f *.o *.a + cd common; rm -f *.o *.exe patchstr infer + cd preproc; rm -f *.o *.exe pp + cd rtt; rm -f *.o *.exe rtt + cd runtime; rm -f *.o *.exe *.c rt.db rt.a rtt*.lst iconx + cd icont; rm -f *.o *.exe icont hdr.h ixhdr.hdr newhdr + cd wincap; rm -f *.o *.exe *.a + cd xpm; rm -f *.o *.exe *.a # force full runtime system rebuild touch h/define.h rm -f h/arch.h @@ -20,12 +19,11 @@ Clean Pure: # The following entry forces rebuilding of everthing from first-generation # files, even files not normally recreated. Doing this requires uncommenting -# some lines in common/Makefile, icont/Makefile, and iconc/Makefile. +# some lines in common/Makefile and icont/Makefile. Force-rebuild: Clean cd h; rm -f kdefs.h cd common; rm -f *.o yacctok.h lextab.h icontype.h \ - doincl fixgram mktoktab patchstr pscript typespec + fixgram mktoktab patchstr pscript typespec cd icont; rm -f *.o icont mkkwd trash \ hdr.h keyword.h tgram.g ttoken.h tparse.c - cd iconc; rm -f *.o iconc cgram.g ctoken.h cparse.h diff --git a/src/common/Makefile b/src/common/Makefile index bb5546a..9456be5 100644 --- a/src/common/Makefile +++ b/src/common/Makefile @@ -3,13 +3,9 @@ include ../../Makedefs OBJS = long.o getopt.o time.o filepart.o identify.o strtbl.o rtdb.o\ munix.o literals.o rswitch.o alloc.o long.o getopt.o time.o\ - xwindow.o dlrgint.o ipp.o + xwindow.o ipp.o -common: doincl $(OBJS) gpxmaybe - -doincl: doincl.c ../h/arch.h - $(CC) $(CFLAGS) -o doincl doincl.c - -./doincl -o ../../bin/rt.h ../h/rt.h +common: $(OBJS) gpxmaybe patchstr: patchstr.c $(CC) $(CFLAGS) -o patchstr patchstr.c @@ -40,20 +36,13 @@ literals.o: ../h/esctab.h rtdb.o: ../h/version.h icontype.h -dlrgint.o: ../h/rproto.h ../h/rexterns.h ../h/rmacros.h ../h/rstructs.h - xwindow.o: ../h/graphics.h ../h/xwin.h -# for rswitch, $(CFLAGS) is deliberately omitted (-O may cause problems) -rswitch.o: ../h/define.h ../h/arch.h $(RSW) - $(CC) -c $(RSW) - # The following section is needed if changes are made to the Icon grammar, # but it is not run as part of the normal installation process. If it is -# needed, it is run by changing ../icont/Makefile and/or ../iconc/Makefile; -# see the comments there for details. icont must be in the search path -# for this section to work. +# needed, it is run by changing ../icont/Makefile; see the comments there +# for details. icont must be in the search path for this section to work. gfiles: lextab.h yacctok.h fixgram pscript diff --git a/src/common/alloc.c b/src/common/alloc.c index 7a048b1..e3b7503 100644 --- a/src/common/alloc.c +++ b/src/common/alloc.c @@ -4,11 +4,6 @@ #include "../h/gsupport.h" -#ifdef TypTrc - int typealloc = 0; /* type allocation switch */ - long typespace = 0; /* type allocation amount */ -#endif /* TypTrc */ - /* * salloc - allocate and initialize string */ @@ -35,24 +30,6 @@ unsigned int n; { register pointer a; -#ifdef AllocTrace - static int sum = 0; -#endif /* AllocTrace */ - -#ifdef TypTrc - if (typealloc) - typespace += (long)n; -#endif /* TypTrc */ - -#ifdef AllocTrace - sum = sum + n; - if (sum > 5000) { - fprintf(stderr, "."); - fflush(stderr); - sum = 0; - }; -#endif /* AllocTrace */ - if (n == 0) /* Work-around for 0 allocation */ n = 1; diff --git a/src/common/dlrgint.c b/src/common/dlrgint.c deleted file mode 100644 index 3ca79d1..0000000 --- a/src/common/dlrgint.c +++ /dev/null @@ -1,252 +0,0 @@ -/* - * dlrgint.c - versions of "large integer" routines for compiled programs - * that do not support large integers. - */ -#define COMPILER 1 -#include "../h/rt.h" - -/* - ***************************************************************** - * - * Routines in the first set are only called when large integers - * exist and thus these versions will never be called. They need - * only have the correct signature and compile without error. - */ - -/* - * bignum -> file - */ -void bigprint(f, da) -FILE *f; -dptr da; - { - } - -/* - * bignum -> real - */ -double bigtoreal(da) -dptr da; - { - return 0.0; - } - -/* - * bignum -> string - */ -int bigtos(da, dx) -dptr da, dx; - { - return 0; - } - -/* - * da -> dx - */ -int cpbignum(da, dx) -dptr da, dx; - { - return 0; - } - -/* - * da / db -> dx - */ -int bigdiv(da, db, dx) -dptr da, db, dx; - { - return 0; - } - -/* - * da % db -> dx - */ -int bigmod(da, db, dx) -dptr da, db, dx; - { - return 0; - } - -/* - * iand(da, db) -> dx - */ -int bigand(da, db, dx) -dptr da, db, dx; - { - return 0; - } - -/* - * ior(da, db) -> dx - */ -int bigor(da, db, dx) -dptr da, db, dx; - { - return 0; - } - -/* - * xor(da, db) -> dx - */ -int bigxor(da, db, dx) -dptr da, db, dx; - { - return 0; - } - -/* - * negative if da < db - * zero if da == db - * positive if da > db - */ -word bigcmp(da, db) -dptr da, db; - { - return (word)0; - } - -/* - * ?da -> dx - */ -int bigrand(da, dx) -dptr da, dx; - { - return 0; - } - -/* - ************************************************************* - * - * The following routines are called when overflow has occurred - * during ordinary arithmetic. - */ - -/* - * da + db -> dx - */ -int bigadd(da, db, dx) -dptr da, db; -dptr dx; - { - t_errornumber = 203; - t_errorvalue = nulldesc; - t_have_val = 0; - return Error; - } - -/* - * da * db -> dx - */ -int bigmul(da, db, dx) -dptr da, db, dx; - { - t_errornumber = 203; - t_errorvalue = nulldesc; - t_have_val = 0; - return Error; - } - -/* - * -i -> dx - */ -int bigneg(da, dx) -dptr da, dx; - { - t_errornumber = 203; - t_errorvalue = nulldesc; - t_have_val = 0; - return Error; - } - -/* - * da - db -> dx - */ -int bigsub(da, db, dx) -dptr da, db, dx; - { - t_errornumber = 203; - t_errorvalue = nulldesc; - t_have_val = 0; - return Error; - } - -/* - * ******************************************************** - * - * The remaining routines each requires different handling. - */ - -/* - * real -> bignum - */ -int realtobig(da, dx) -dptr da, dx; - { - return Failed; /* conversion cannot be done */ - } - -/* - * da ^ db -> dx - */ -int bigpow(da, db, dx) -dptr da, db, dx; - { - C_integer r; - extern int over_flow; - - /* - * Just do ordinary interger exponentiation and check for overflow. - */ - r = iipow(IntVal(*da), IntVal(*db)); - if (over_flow) { - k_errornumber = 203; - k_errortext = ""; - k_errorvalue = nulldesc; - have_errval = 0; - return Error; - } - MakeInt(r, dx); - return Succeeded; - } - -/* - * string -> bignum - */ -word bigradix(sign, r, s, end_s, result) -int sign; /* '-' or not */ -int r; /* radix 2 .. 36 */ -char *s, *end_s; /* input string */ -union numeric *result; /* output T_Integer or T_Lrgint */ - { - /* - * Just do string to ordinary integer. - */ - return radix(sign, r, s, end_s, result); - } - -/* - * bigshift(da, db) -> dx - */ -int bigshift(da, db, dx) -dptr da, db, dx; - { - uword ci; /* shift in 0s, even if negative */ - C_integer cj; - - /* - * Do an ordinary shift - note that db is always positive when this - * routine is called. - */ - ci = (uword)IntVal(*da); - cj = IntVal(*db); - /* - * Check for a shift of WordSize or greater; return an explicit 0 because - * this is beyond C's defined behavior. Otherwise shift as requested. - */ - if (cj >= WordBits) - ci = 0; - else - ci <<= cj; - MakeInt(ci, dx); - return Succeeded; - } diff --git a/src/common/doincl.c b/src/common/doincl.c deleted file mode 100644 index 8f80c87..0000000 --- a/src/common/doincl.c +++ /dev/null @@ -1,77 +0,0 @@ -/* - * doincl.c -- expand include directives (recursively) - * - * Usage: doinclude [-o outfile] filename... - * - * Doinclude copies a C source file, expanding non-system include directives. - * For each line of the form - * #include "filename" - * the named file is interpolated; all other lines are copied verbatim. - * - * No error is generated if a file cannot be opened. - */ - -#include "../h/rt.h" - -void doinclude (char *fname); - -#define MAXLINE 500 /* maximum line length */ - -FILE *outfile; /* output file */ - -int main(argc, argv) -int argc; -char *argv[]; - { - char *progname = argv[0]; - - outfile = stdout; - if (argc > 3 && strcmp(argv[1], "-o") == 0) { - if ((outfile = fopen(argv[2], "w")) != NULL) { - argv += 2; - argc -= 2; - } - else { - perror(argv[2]); - exit(1); - } - } - if (argc < 2) { - fprintf(stderr, "usage: %s [-o outfile] filename...\n", progname); - exit(1); - } - - fprintf(outfile, - "/***** do not edit -- this file was generated mechanically *****/\n\n"); - while (--argc > 0) - doinclude(*++argv); - exit(0); - /*NOTREACHED*/ - } - -void doinclude(fname) -char *fname; - { - FILE *f; - char line[MAXLINE], newname[MAXLINE], *p; - - fprintf(outfile, "\n\n/****************************************"); - fprintf(outfile, " from %s: */\n\n", fname); - if ((f = fopen(fname, "r")) != NULL) { - while (fgets(line, MAXLINE, f)) - if (sscanf(line, " # include \"%s\"", newname) == 1) { - for (p = newname; *p != '\0' && *p != '"'; p++) - ; - *p = '\0'; /* strip off trailing '"' */ - doinclude(newname); /* include file */ - } - else - fputs(line, outfile); /* not an include directive */ - fclose(f); - } - else { - fprintf(outfile, "/* [file not found] */\n"); - } - fprintf(outfile, "\n/****************************************"); - fprintf(outfile, " end %s */\n", fname); - } diff --git a/src/common/error.h b/src/common/error.h index 0c5cb83..77ce243 100644 --- a/src/common/error.h +++ b/src/common/error.h @@ -2,8 +2,6 @@ * error.h -- routines for producing error messages. * * This source file contains the routines for issuing error messages. - * It is built by inclusion in ../icont/tlex.c and ../iconc/clex.c, - * with slight variations depending on whether "Iconc" is defined. */ /* @@ -110,25 +108,6 @@ char *s1, *s2; nocode++; } -#ifdef Iconc -/* - * twarn produces s1 and s2 (if nonnull) as translator warning messages. - * The location of the error is found in tok_loc. - */ -void twarn(s1, s2) -char *s1, *s2; - { - - if (tok_loc.n_file) - fprintf(stderr, "File %s; ", tok_loc.n_file); - fprintf(stderr, "Line %d # ", tok_loc.n_line); - if (s2) - fprintf(stderr, "\"%s\": ", s2); - fprintf(stderr, "%s\n", s1); - twarns++; - } -#endif /* Iconc */ - /* * tsyserr is called for fatal errors. The message s is produced and the * translator exits. @@ -162,18 +141,12 @@ void quitf(msg,arg) char *msg, *arg; { extern char *progname; + extern char *ofile; fprintf(stderr,"%s: ",progname); fprintf(stderr,msg,arg); fprintf(stderr,"\n"); - - #if !defined(Iconc) - { - extern char *ofile; - if (ofile) - remove(ofile); /* remove bad icode file */ - } - #endif /* !Iconc */ - + if (ofile) + remove(ofile); /* remove bad icode file */ exit(EXIT_FAILURE); } diff --git a/src/common/filepart.c b/src/common/filepart.c index ab8049a..3c0b2de 100644 --- a/src/common/filepart.c +++ b/src/common/filepart.c @@ -38,22 +38,14 @@ static char *tryfile (char *buf, char *dir, char *name, char *extn); char *pathfind(buf, path, name, extn) char *buf, *path, *name, *extn; { - char *s; char pbuf[MaxPath]; if (tryfile(buf, (char *)NULL, name, extn)) /* try curr directory first */ return buf; - if (!path) /* if no path, use default */ + if (!path) /* if no path, use default */ path = DefPath; - #if CYGWIN - s = alloca(cygwin_win32_to_posix_path_list_buf_size(path)); - cygwin_win32_to_posix_path_list(path, s); - #else /* CYGWIN */ - s = path; - #endif /* CYGWIN */ - - while ((s = pathelem(s, pbuf)) != 0) /* for each path element */ + while ((path = pathelem(path, pbuf)) != 0) /* for each path element */ if (tryfile(buf, pbuf, name, extn)) /* look for file */ return buf; return NULL; /* return NULL if no file found */ @@ -123,12 +115,6 @@ char *s; int n; char *p, *q; - #if CYGWIN - char posix_s[_POSIX_PATH_MAX + 1]; - cygwin_conv_to_posix_path(s, posix_s); - s = posix_s; - #endif /* CYGWIN */ - q = s; fp.ext = p = s + strlen(s); while (--p >= s) { diff --git a/src/common/identify.c b/src/common/identify.c index a1b7038..a9e4319 100644 --- a/src/common/identify.c +++ b/src/common/identify.c @@ -1,7 +1,5 @@ #include "../h/gsupport.h" -#undef COMPILER -#define COMPILER 1 /* insure compiler Version number */ #include "../h/version.h" extern char *progname; diff --git a/src/common/infer.c b/src/common/infer.c index 819bf8b..aa38ea8 100644 --- a/src/common/infer.c +++ b/src/common/infer.c @@ -23,8 +23,8 @@ int main(int argc, char *argv[]) { assert (sizeof(int) >= 4); /* need 32-bit ints or better */ assert (sizeof(long) <= 8); /* but can't handle over 64 */ printf("/* generated by infer.c */\n"); - printf("#define IntBits %d\n", 8 * sizeof(int)); - printf("#define WordBits %d\n", 8 * sizeof(void *)); + printf("#define IntBits %d\n", (int) (8 * sizeof(int))); + printf("#define WordBits %d\n", (int) (8 * sizeof(void *))); if (offsetof(tstruct, d) > sizeof(void *)) printf("#define Double\n"); if (atdepth(2) > atdepth(1)) diff --git a/src/common/ipp.c b/src/common/ipp.c index 8913ee5..36a0990 100644 --- a/src/common/ipp.c +++ b/src/common/ipp.c @@ -18,7 +18,7 @@ * ppinit(fname,inclpath,m4flag) -- open input file * ppdef(s,v) -- "$define s v", or "$undef s" if v is a null pointer * ppch() -- return next preprocessed character - * ppecho() -- preprocess to stdout (for icont/iconc -E) + * ppecho() -- preprocess to stdout (for icont -E) * * See ../h/features.h for the set of predefined symbols. */ @@ -115,7 +115,7 @@ static char *lpath; /* LPATH for finding source files */ static int ifdepth; /* depth of $if nesting */ -extern int tfatals, nocode; /* provided by icont, iconc */ +extern int tfatals, nocode; /* provided by icont */ /* * ppinit(fname, inclpath, m4) -- initialize preprocessor to read from fname. diff --git a/src/common/munix.c b/src/common/munix.c index 132f397..f7dc6d0 100644 --- a/src/common/munix.c +++ b/src/common/munix.c @@ -29,12 +29,6 @@ char *relfile(char *prog, char *mod) { if (baseloc[0] == 0) { /* if argv[0] not already found */ - #if CYGWIN - char posix_prog[_POSIX_PATH_MAX + 1]; - cygwin_conv_to_posix_path(prog, posix_prog); - prog = posix_prog; - #endif /* CYGWIN */ - if (findexe(prog, baseloc, sizeof(baseloc)) == NULL) { fprintf(stderr, "cannot find location of %s\n", prog); exit(EXIT_FAILURE); @@ -102,14 +96,6 @@ char *findonpath(char *name, char *buf, size_t len) { if (path == NULL || *path == '\0') path = "."; - #if CYGWIN - else { - char *posix_path; - posix_path = alloca(cygwin_win32_to_posix_path_list_buf_size(path)); - cygwin_win32_to_posix_path_list(path, posix_path); - path = posix_path; - } - #endif /* CYGWIN */ end = path + strlen(path); for (next = path; next <= end; next = sep + 1) { diff --git a/src/common/pscript.icn b/src/common/pscript.icn index d9b2ee7..10d10d2 100644 --- a/src/common/pscript.icn +++ b/src/common/pscript.icn @@ -6,11 +6,7 @@ procedure sws() return tab( many( ' \t' ) ) | "" end -$ifdef _CYGWIN - $define YY_STATE "yystate" -$else # _CYGWIN - $define YY_STATE "yy_state" -$endif # _CYGWIN +$define YY_STATE "yy_state" procedure main() local line, prefix diff --git a/config/pthreads.c b/src/common/rswitch.c index 1ebf7c7..9373b4e 100644 --- a/config/pthreads.c +++ b/src/common/rswitch.c @@ -1,18 +1,15 @@ /* - * pthreads.c -- Icon context switch code using POSIX threads and semaphores + * rswitch.c -- context switch code using POSIX threads and semaphores * * This code implements co-expression context switching on any system that - * provides POSIX threads and semaphores. It requires Icon 9.4.1 or later - * built with "#define CoClean" in order to free threads and semaphores when - * co-expressions are collected. It is typically much slower when called - * than platform-specific custom code, but of course it is much more portable, - * and it is typically used infrequently. + * provides POSIX threads and semaphores. * - * Unnamed semaphores are used unless NamedSemaphores is defined. - * (This is for Mac OS 10.3 which does not have unnamed semaphores.) + * Anonymous semaphores are used unless NamedSemaphores is defined. + * (This is for MacOS which does not have anonymous semaphores.) */ #include <fcntl.h> +#include <limits.h> #include <pthread.h> #include <semaphore.h> #include <stdio.h> @@ -26,7 +23,10 @@ extern void new_context(int, void *); extern void syserr(char *msg); extern void *alloc(unsigned int n); +extern long stksize; /* value of COEXPSIZE */ + static int inited = 0; /* has first-time initialization been done? */ +static pthread_attr_t attribs; /* thread creation attributes */ /* * Define a "context" struct to hold the thread information we need. @@ -40,6 +40,7 @@ typedef struct { static void makesem(context *ctx); static void *nctramp(void *arg); +static void uerror(char *msg); /* * Treat an Icon "cstate" array as an array of context pointers. @@ -57,6 +58,8 @@ int coswitch(void *o, void *n, int first) { cstate ocs = o; /* old cstate pointer */ cstate ncs = n; /* new cstate pointer */ context *old, *new; /* old and new context pointers */ + size_t newsize; /* stack size for new thread */ + size_t pagesize; /* system page size */ if (inited) /* if not first call */ old = ocs[1]; /* load current context pointer */ @@ -69,6 +72,25 @@ int coswitch(void *o, void *n, int first) { makesem(old); old->thread = pthread_self(); old->alive = 1; + + /* + * Set up thread attributes to honor COEXPSIZE for setting stack size. + */ + pagesize = sysconf(_SC_PAGESIZE); + newsize = stksize; + #ifdef PTHREAD_STACK_MIN + if (newsize < PTHREAD_STACK_MIN) /* ensure system minimum is met */ + newsize = PTHREAD_STACK_MIN; + #endif + if (pagesize > 0 && (newsize % pagesize) != 0) { + /* some systems require an exact multiple of the system page size */ + newsize = newsize + pagesize - (newsize % pagesize); + } + pthread_attr_init(&attribs); + if (pthread_attr_setstacksize(&attribs, newsize) != 0) { + uerror("cannot set stacksize for thread"); + } + inited = 1; } @@ -81,8 +103,8 @@ int coswitch(void *o, void *n, int first) { */ new = ncs[1] = alloc(sizeof(context)); makesem(new); - if (pthread_create(&new->thread, NULL, nctramp, new) != 0) - syserr("cannot create thread"); + if (pthread_create(&new->thread, &attribs, nctramp, new) != 0) + uerror("cannot create thread"); new->alive = 1; } @@ -122,11 +144,11 @@ static void makesem(context *ctx) { sprintf(name, "i%ld.sem", (long)getpid()); ctx->semp = sem_open(name, O_CREAT, S_IRUSR | S_IWUSR, 0); if (ctx->semp == (sem_t *)SEM_FAILED) - syserr("cannot create semaphore"); + uerror("cannot create semaphore"); sem_unlink(name); #else /* NamedSemaphores */ if (sem_init(&ctx->sema, 0, 0) == -1) - syserr("cannot init semaphore"); + uerror("cannot init semaphore"); ctx->semp = &ctx->sema; #endif /* NamedSemaphores */ } @@ -141,3 +163,11 @@ static void *nctramp(void *arg) { syserr("new_context returned to nctramp"); return NULL; } + +/* + * uerror(s) -- abort due to Unix error. + */ +static void uerror(char *msg) { + perror(msg); + syserr(NULL); + } diff --git a/src/common/rtdb.c b/src/common/rtdb.c index 5467244..d656d29 100644 --- a/src/common/rtdb.c +++ b/src/common/rtdb.c @@ -1066,9 +1066,6 @@ static struct il_c *db_ilc() case 'g': db_chstr("$cg", "oto"); *nxtp = new_ilc(ILC_CGto); -#ifdef MultiThread - #undef code -#endif /* MultiThead */ (*nxtp)->code[0] = db_ilc(); c = getc(db); SkipWhSp(c); diff --git a/src/common/yylex.h b/src/common/yylex.h index 9850417..37643f5 100644 --- a/src/common/yylex.h +++ b/src/common/yylex.h @@ -2,14 +2,10 @@ * yylex.h -- the lexical analyzer. * * This source file contains the lexical analyzer, yylex(), and its - * support routines. It is built by inclusion in ../icont/tlex.c and - * ../iconc/clex.c, with slight variations depending on whether "Iconc" - * is defined. + * support routines. It is built by inclusion in ../icont/tlex.c. */ -#if !defined(Iconc) - #include "../h/esctab.h" -#endif /* !Iconc */ +#include "../h/esctab.h" /* * Prototypes. @@ -23,11 +19,9 @@ static struct toktab *getstring (int ac,int *cc); static int setfilenm (int c); static int setlineno (void); -#if !defined(Iconc) - static int ctlesc (void); - static int hexesc (void); - static int octesc (int ac); -#endif /* !Iconc */ +static int ctlesc (void); +static int hexesc (void); +static int octesc (int ac); #define isletter(s) (isupper(c) | islower(c)) #define tonum(c) (isdigit(c) ? (c - '0') : ((c & 037) + 9)) @@ -399,16 +393,6 @@ int *cc; c = NextChar; if (c == EOF) break; - -#if defined(Iconc) - AppChar(lex_sbuf, Escape); - if (c == '^') { - c = NextChar; - if (c == EOF) - break; - AppChar(lex_sbuf, '^'); - } -#else /* Iconc */ if (isoctal(c)) c = octesc(c); else if (c == 'x') @@ -417,9 +401,8 @@ int *cc; c = ctlesc(); else c = esctab[c]; -#endif /* Iconc */ - } + AppChar(lex_sbuf, c); c = NextChar; @@ -451,8 +434,6 @@ int *cc; } } -#if !defined(Iconc) - /* * ctlesc - translate a control escape -- backslash followed by * caret and one character. @@ -523,8 +504,6 @@ static int hexesc() return c; } - -#endif /* !Iconc */ /* * setlineno - set line number from #line comment, return following char. diff --git a/src/h/config.h b/src/h/config.h index bc48ada..2045dd7 100644 --- a/src/h/config.h +++ b/src/h/config.h @@ -9,70 +9,14 @@ /* * A number of symbols are defined here. * Some enable or disable certain Icon features, for example: - * NoCoexpr disables co-expressions * LoadFunc enables dynamic loading * - * Other definitions may occur for different configurations. These include: - * DeBug debugging code - * MultiThread support for multiple programs under the interpreter - * * Many definitions reflect remnants of past research projects. * Changing them to values not used in standard configurations * may result in an unbuildable or nonfunctioning system. */ /* - * If COMPILER is not defined, code for the interpreter is compiled. - */ - -#ifndef COMPILER - #define COMPILER 0 -#endif - -/* - * The following definitions serve to cast common conditionals is - * a positive way, while allowing defaults for the cases that - * occur most frequently. That is, if co-expressions are not supported, - * NoCoexpr is defined in define.h, but if they are supported, no - * definition is needed in define.h; nonetheless subsequent conditionals - * can be cast as #ifdef Coexpr. - */ - -#ifndef NoCoexpr - #undef Coexpr - #define Coexpr -#endif /* NoCoexpr */ - -#ifdef NoCoexpr - #undef MultiThread - #undef EventMon - #undef Eve -#endif /* NoCoexpr */ - -#if COMPILER - #undef Eve - #undef MultiThread - #undef EventMon -#endif /* COMPILER */ - -#ifdef Eve - #undef EventMon - #undef MultiThread - #define EventMon - #define MultiThread -#endif /* Eve */ - -#ifndef NoLargeInts - #undef LargeInts - #define LargeInts -#endif /* NoLargeInts */ - -#ifdef EventMon - #undef MultiThread - #define MultiThread -#endif /* EventMon */ - -/* * Graphics definitions. */ #ifdef Graphics @@ -99,14 +43,9 @@ #undef Polling #define Polling - #ifndef ICONC_XLIB - #ifdef WinGraphics - #define ICONC_XLIB "-luser32 -lgdi32 -lcomdlg32 -lwinmm" - #else /* WinGraphics */ - #define ICONC_XLIB "-L/usr/X11R6/lib -lX11" - #endif /* WinGraphics */ - #endif /* ICONC_XLIB */ - +#else /* Graphics */ + #undef XWindows + #undef WinGraphics #endif /* Graphics */ /* @@ -123,15 +62,6 @@ * Other defaults. */ -#ifdef DeBug - #undef DeBugTrans - #undef DeBugLinker - #undef DeBugIconx - #define DeBugTrans - #define DeBugLinker - #define DeBugIconx -#endif /* DeBug */ - #ifndef MaxHdr /* * Maximum allowable BinaryHeader size. @@ -141,7 +71,7 @@ #endif /* MaxHdr */ #ifndef MaxPath - #define MaxPath 256 + #define MaxPath 512 #endif /* MaxPath */ #ifndef SourceSuffix @@ -206,18 +136,10 @@ #define DBSuffix ".db" #endif /* DBSuffix */ -#ifndef PPInit - #define PPInit "" -#endif /* PPInit */ - #ifndef PPDirectives #define PPDirectives {"passthru", PpKeep}, #endif /* PPDirectives */ -#ifndef NoSrcColumnInfo - #define SrcColumnInfo -#endif /* NoSrcColumnInfo */ - #ifndef ExecSuffix #define ExecSuffix "" #endif /* ExecSuffix */ @@ -226,66 +148,34 @@ #define CSuffix ".c" #endif /* CSuffix */ -#ifndef HSuffix - #define HSuffix ".h" -#endif /* HSuffix */ - -#ifndef ObjSuffix - #define ObjSuffix ".o" -#endif /* ObjSuffix */ - -#ifndef LibSuffix - #define LibSuffix ".a" -#endif /* LibSuffix */ - -#ifndef CComp - #define CComp "cc" -#endif /* CComp */ - -#ifndef COpts - #define COpts "" -#endif /* COpts */ - /* * Note, size of the hash table is a power of 2: */ #define IHSize 128 #define IHasher(x) (((unsigned int)(unsigned long)(x))&(IHSize-1)) -#if COMPILER - - /* - * Code for the compiler. - */ - #undef MultiThread /* no way -- interpreter only */ - #undef EventMon /* presently not supported in the compiler */ - -#else /* COMPILER */ - - /* - * Code for the interpreter. - */ - #ifndef IcodeSuffix - #define IcodeSuffix "" - #endif /* IcodeSuffix */ - - #ifndef IcodeASuffix - #define IcodeASuffix "" - #endif /* IcodeASuffix */ +/* + * Code for the interpreter. + */ +#ifndef IcodeSuffix + #define IcodeSuffix "" +#endif /* IcodeSuffix */ - #ifndef U1Suffix - #define U1Suffix ".u1" - #endif /* U1Suffix */ +#ifndef IcodeASuffix + #define IcodeASuffix "" +#endif /* IcodeASuffix */ - #ifndef U2Suffix - #define U2Suffix ".u2" - #endif /* U2Suffix */ +#ifndef U1Suffix + #define U1Suffix ".u1" +#endif /* U1Suffix */ - #ifndef USuffix - #define USuffix ".u" - #endif /* USuffix */ +#ifndef U2Suffix + #define U2Suffix ".u2" +#endif /* U2Suffix */ -#endif /* COMPILER */ +#ifndef USuffix + #define USuffix ".u" +#endif /* USuffix */ /* * Vsizeof is for use with variable-sized (i.e., indefinite) diff --git a/src/h/cpuconf.h b/src/h/cpuconf.h index 228ce6b..acd0194 100644 --- a/src/h/cpuconf.h +++ b/src/h/cpuconf.h @@ -4,10 +4,6 @@ * included before this file. */ -#ifndef CStateSize - #define CStateSize 15 /* size of C state for co-expressions */ -#endif /* CStateSize */ - /* * The following definitions depend on the sizes of ints and pointers. */ @@ -215,11 +211,7 @@ #endif /* MinAbrSize */ #ifndef MStackSize - #ifdef MultiThread - #define MStackSize 20000 /* size of the main stack in words */ - #else /* MultiThread */ - #define MStackSize 10000 /* size of the main stack in words */ - #endif /* MultiThread */ + #define MStackSize 10000 /* size of the main stack in words */ #endif /* MStackSize */ #ifndef StackSize @@ -231,11 +223,7 @@ #endif /* QualLstSize */ #ifndef ActStkBlkEnts - #ifdef Coexpr - #define ActStkBlkEnts 25 /* number of entries in an astkblk */ - #else /* Coexpr */ - #define ActStkBlkEnts 1 /* number of entries in an astkblk */ - #endif /* Coexpr */ + #define ActStkBlkEnts 25 /* number of entries in an astkblk */ #endif /* ActStkBlkEnts */ #ifndef RegionCushion diff --git a/src/h/fdefs.h b/src/h/fdefs.h index 8f35509..c5a36fc 100644 --- a/src/h/fdefs.h +++ b/src/h/fdefs.h @@ -20,6 +20,7 @@ FncDef(cset,1) FncDef(delay,1) FncDef(delete,2) FncDefV(detab) +FncDef(display,2) FncDef(dtor,1) FncDefV(entab) FncDef(errorclear,0) @@ -47,10 +48,12 @@ FncDef(map,3) FncDef(match,4) FncDef(member,1) FncDef(move,1) +FncDef(name,1) FncDef(numeric,1) FncDef(ord,1) FncDef(pop,1) FncDef(pos,1) +FncDef(proc,2) FncDef(pull,1) FncDefV(push) FncDefV(put) @@ -81,6 +84,7 @@ FncDef(tan,1) FncDef(trim,2) FncDef(type,1) FncDef(upto,4) +FncDef(variable,1) FncDef(where,1) FncDefV(write) FncDefV(writes) @@ -91,18 +95,6 @@ FncDefV(writes) FncDef(open,3) #endif /* Graphics */ -#ifdef MultiThread - FncDef(display,3) - FncDef(name,2) - FncDef(proc,3) - FncDef(variable,3) -#else /* MultiThread */ - FncDef(display,2) - FncDef(name,1) - FncDef(proc,2) - FncDef(variable,1) -#endif /* MultiThread */ - /* * Dynamic loading. */ @@ -111,13 +103,6 @@ FncDefV(writes) #endif /* LoadFunc */ /* - * External functions. - */ -#ifdef ExternalFunctions - FncDefV(callout) -#endif /* ExternalFunctions */ - -/* * File attribute function. */ #ifdef FAttrib @@ -134,16 +119,6 @@ FncDefV(writes) #endif /* KeyboardFncs */ /* - * Event processing functions. - */ -#ifdef EventMon - FncDef(EvGet,2) - FncDef(event,3) - FncDef(eventmask,2) - FncDef(opmask,2) -#endif /* EventMon */ - -/* * Graphics functions. */ #ifdef Graphics @@ -211,22 +186,3 @@ FncDefV(writes) FncDefV(WinSelectDialog) #endif /* WinExtns */ #endif /* Graphics */ - -#ifdef MultiThread - /* - * These functions are part of the MultiThread extensions. - */ - FncDef(cofail,1) - FncDef(globalnames,1) - FncDef(fieldnames,1) - FncDef(localnames,2) - FncDef(staticnames,2) - FncDef(paramnames,2) - FncDef(structure,1) - /* - * These functions are inherent to MultiThread and multiple Icon programs - */ - FncDefV(load) - FncDef(parent,1) - FncDef(keyword,2) -#endif /* MultiThread */ diff --git a/src/h/features.h b/src/h/features.h index 047b4df..b22633a 100644 --- a/src/h/features.h +++ b/src/h/features.h @@ -18,6 +18,14 @@ Feature(1, "_V9", 0) /* Version 9 (unconditional) */ +#if UNIX + Feature(1, "_UNIX", "UNIX") +#endif /* UNIX */ + +#if MACINTOSH + Feature(1, "_MACINTOSH", "Macintosh") +#endif /* MACINTOSH */ + #if MSWIN Feature(1, "_MS_WINDOWS", "MS Windows") #endif /* MSWIN */ @@ -26,15 +34,9 @@ Feature(1, "_CYGWIN", "Cygwin") #endif /* CYGWIN */ -#if UNIX - Feature(1, "_UNIX", "UNIX") -#endif /* UNIX */ - Feature(1, "_ASCII", "ASCII") -#ifdef Coexpr Feature(1, "_CO_EXPRESSIONS", "co-expressions") -#endif /* Coexpr */ #ifdef LoadFunc Feature(1, "_DYNAMIC_LOADING", "dynamic loading") @@ -42,25 +44,15 @@ Feature(1, "", "environment variables") -#ifdef EventMon - Feature(1, "_EVENT_MONITOR", "event monitoring") -#endif /* EventMon */ - -#ifdef ExternalFunctions - Feature(1, "_EXTERNAL_FUNCTIONS", "external functions") -#endif /* ExternalFunctions */ +#ifdef LoadFunc + Feature(1, "_EXTERNAL_VALUES", "external values") +#endif /* LoadFunc */ #ifdef KeyboardFncs Feature(1, "_KEYBOARD_FUNCTIONS", "keyboard functions") #endif /* KeyboardFncs */ -#ifdef LargeInts Feature(largeints, "_LARGE_INTEGERS", "large integers") -#endif /* LargeInts */ - -#ifdef MultiThread - Feature(1, "_MULTITASKING", "multiple programs") -#endif /* MultiThread */ #ifdef Pipes Feature(1, "_PIPES", "pipes") diff --git a/src/h/grttin.h b/src/h/grttin.h index 1247ca2..4a0be07 100644 --- a/src/h/grttin.h +++ b/src/h/grttin.h @@ -72,63 +72,6 @@ */ #define Protect(notnull,orelse) do {if ((notnull)==NULL) orelse;} while(0) -#ifdef EventMon -/* - * perform what amounts to "function inlining" of EVVal - */ -#begdef EVVal(value,event) - do { - if (is:null(curpstate->eventmask)) break; - else if (!Testb((word)event, curpstate->eventmask)) break; - MakeInt(value, &(curpstate->parent->eventval)); - actparent(event); - } while (0) -#enddef /* EVVal */ -#begdef EVValD(dp,event) - do { - if (is:null(curpstate->eventmask)) break; - else if (!Testb((word)event, curpstate->eventmask)) break; - curpstate->parent->eventval = *(dp); - actparent(event); - } while (0) -#enddef /* EVValD */ -#begdef EVValX(bp,event) - do { - struct progstate *parent = curpstate->parent; - if (is:null(curpstate->eventmask)) break; - else if (!Testb((word)event, curpstate->eventmask)) break; - parent->eventval.dword = D_Coexpr; - BlkLoc(parent->eventval) = (union block *)(bp); - actparent(event); - } while (0) -#enddef /* EVValX */ - -#define InterpEVVal(arg1,arg2) { ExInterp; EVVal(arg1,arg2); EntInterp; } -#define InterpEVValD(arg1,arg2) { ExInterp; EVValD(arg1,arg2); EntInterp; } -#define InterpEVValX(arg1,arg2) { ExInterp; EVValX(arg1,arg2); EntInterp; } - -/* - * Macro with construction of event descriptor. - */ - -#begdef Desc_EVValD(bp, code, type) - do { - eventdesc.dword = type; - eventdesc.vword.bptr = (union block *)(bp); - EVValD(&eventdesc, code); - } while (0) -#enddef /* Desc_EVValD */ - -#else /* EventMon */ - #define EVVal(arg1,arg2) - #define EVValD(arg1,arg2) - #define EVValX(arg1,arg2) - #define InterpEVVal(arg1,arg2) - #define InterpEVValD(arg1,arg2) - #define InterpEVValX(arg1,arg2) - #define Desc_EVValD(bp, code, type) -#endif /* EventMon */ - /* * dummy typedefs for things defined in #include files */ diff --git a/src/h/header.h b/src/h/header.h index 3b131f1..6c9e3f4 100644 --- a/src/h/header.h +++ b/src/h/header.h @@ -15,14 +15,6 @@ struct header { word Strcons; /* location of identifier table */ word Filenms; /* location of ipc/file name table */ - #ifdef FieldTableCompression - short FtabWidth; /* width of field table entries, 1 | 2 | 4 */ - short FoffWidth; /* width of field offset entries, 1 | 2 | 4 */ - word Nfields; /* number of field names */ - word Fo; /* The start of the Fo array */ - word Bm; /* The start of the Bm array */ - #endif /* FieldTableCompression */ - word linenums; /* location of ipc/line number table */ word config[16]; /* icode version */ }; diff --git a/src/h/monitor.h b/src/h/monitor.h deleted file mode 100644 index e359e9e..0000000 --- a/src/h/monitor.h +++ /dev/null @@ -1,213 +0,0 @@ -/* - * This file contains definitions for the various event codes and values - * that go to make up event streams. - */ - -/* - * Note: the blank character should *not* be used as an event code. - */ - -#ifdef EventMon - -/* - * Allocation events use lowercase codes. - */ -#define E_Lrgint '\114' /* Large integer allocation */ -#define E_Real '\144' /* Real allocation */ -#define E_Cset '\145' /* Cset allocation */ -#define E_File '\147' /* File allocation */ -#define E_Record '\150' /* Record allocation */ -#define E_Tvsubs '\151' /* Substring tv allocation */ -#define E_External '\152' /* External allocation */ -#define E_List '\153' /* List allocation */ -#define E_Lelem '\155' /* List element allocation */ -#define E_Table '\156' /* Table allocation */ -#define E_Telem '\157' /* Table element allocation */ -#define E_Tvtbl '\160' /* Table-element tv allocation */ -#define E_Set '\161' /* Set allocation */ -#define E_Selem '\164' /* Set element allocation */ -#define E_Slots '\167' /* Hash header allocation */ -#define E_Coexpr '\170' /* Co-expression allocation */ -#define E_Refresh '\171' /* Refresh allocation */ -#define E_Alien '\172' /* Alien allocation */ -#define E_Free '\132' /* Free region */ -#define E_String '\163' /* String allocation */ - -/* - * Some other monitoring codes. - */ -#define E_BlkDeAlc '\055' /* Block deallocation */ -#define E_StrDeAlc '\176' /* String deallocation */ - -/* - * These are not "events"; they are provided for uniformity in tools - * that deal with types. - */ -#define E_Integer '\100' /* Integer value pseudo-event */ -#define E_Null '\044' /* Null value pseudo-event */ -#define E_Proc '\045' /* Procedure value pseudo-event */ -#define E_Kywdint '\136' /* Integer keyword value pseudo-event */ -#define E_Kywdpos '\046' /* Position value pseudo-event */ -#define E_Kywdsubj '\052' /* Subject value pseudo-event */ - -/* - * Codes for main sequence events - */ - - /* - * Timing events - */ -#define E_Tick '\056' /* Clock tick */ - - /* - * Code-location event - */ -#define E_Loc '\174' /* Location change */ -#define E_Line '\355' /* Line change */ - - /* - * Virtual-machine instructions - */ -#define E_Opcode '\117' /* Virtual-machine instruction */ - - /* - * Type-conversion events - */ -#define E_Aconv '\111' /* Conversion attempt */ -#define E_Tconv '\113' /* Conversion target */ -#define E_Nconv '\116' /* Conversion not needed */ -#define E_Sconv '\121' /* Conversion success */ -#define E_Fconv '\112' /* Conversion failure */ - - /* - * Structure events - */ -#define E_Lbang '\301' /* List generation */ -#define E_Lcreate '\302' /* List creation */ -#define E_Lget '\356' /* List get/pop -- only E_Lget used */ -#define E_Lpop '\356' /* List get/pop */ -#define E_Lpull '\304' /* List pull */ -#define E_Lpush '\305' /* List push */ -#define E_Lput '\306' /* List put */ -#define E_Lrand '\307' /* List random reference */ -#define E_Lref '\310' /* List reference */ -#define E_Lsub '\311' /* List subscript */ -#define E_Rbang '\312' /* Record generation */ -#define E_Rcreate '\313' /* Record creation */ -#define E_Rrand '\314' /* Record random reference */ -#define E_Rref '\315' /* Record reference */ -#define E_Rsub '\316' /* Record subscript */ -#define E_Sbang '\317' /* Set generation */ -#define E_Screate '\320' /* Set creation */ -#define E_Sdelete '\321' /* Set deletion */ -#define E_Sinsert '\322' /* Set insertion */ -#define E_Smember '\323' /* Set membership */ -#define E_Srand '\336' /* Set random reference */ -#define E_Sval '\324' /* Set value */ -#define E_Tbang '\325' /* Table generation */ -#define E_Tcreate '\326' /* Table creation */ -#define E_Tdelete '\327' /* Table deletion */ -#define E_Tinsert '\330' /* Table insertion */ -#define E_Tkey '\331' /* Table key generation */ -#define E_Tmember '\332' /* Table membership */ -#define E_Trand '\337' /* Table random reference */ -#define E_Tref '\333' /* Table reference */ -#define E_Tsub '\334' /* Table subscript */ -#define E_Tval '\335' /* Table value */ - - /* - * Scanning events - */ - -#define E_Snew '\340' /* Scanning environment creation */ -#define E_Sfail '\341' /* Scanning failure */ -#define E_Ssusp '\342' /* Scanning suspension */ -#define E_Sresum '\343' /* Scanning resumption */ -#define E_Srem '\344' /* Scanning environment removal */ -#define E_Spos '\346' /* Scanning position */ - - /* - * Assignment - */ - -#define E_Assign '\347' /* Assignment */ -#define E_Value '\350' /* Value assigned */ - - /* - * Sub-string assignment - */ - -#define E_Ssasgn '\354' /* Sub-string assignment */ - /* - * Interpreter stack events - */ - -#define E_Intcall '\351' /* interpreter call */ -#define E_Intret '\352' /* interpreter return */ -#define E_Stack '\353' /* stack depth */ - - /* - * Expression events - */ -#define E_Ecall '\143' /* Call of operation */ -#define E_Efail '\146' /* Failure from expression */ -#define E_Bsusp '\142' /* Suspension from operation */ -#define E_Esusp '\141' /* Suspension from alternation */ -#define E_Lsusp '\154' /* Suspension from limitation */ -#define E_Eresum '\165' /* Resumption of expression */ -#define E_Erem '\166' /* Removal of a suspended generator */ - - /* - * Co-expression events - */ - -#define E_Coact '\101' /* Co-expression activation */ -#define E_Coret '\102' /* Co-expression return */ -#define E_Cofail '\104' /* Co-expression failure */ - - /* - * Procedure events - */ - -#define E_Pcall '\103' /* Procedure call */ -#define E_Pfail '\106' /* Procedure failure */ -#define E_Pret '\122' /* Procedure return */ -#define E_Psusp '\123' /* Procedure suspension */ -#define E_Presum '\125' /* Procedure resumption */ -#define E_Prem '\126' /* Suspended procedure removal */ - -#define E_Fcall '\072' /* Function call */ -#define E_Ffail '\115' /* Function failure */ -#define E_Fret '\120' /* Function return */ -#define E_Fsusp '\127' /* Function suspension */ -#define E_Fresum '\131' /* Function resumption */ -#define E_Frem '\133' /* Function suspension removal */ - -#define E_Ocall '\134' /* Operator call */ -#define E_Ofail '\135' /* Operator failure */ -#define E_Oret '\140' /* Operator return */ -#define E_Osusp '\173' /* Operator suspension */ -#define E_Oresum '\175' /* Operator resumption */ -#define E_Orem '\177' /* Operator suspension removal */ - - /* - * Garbage collections - */ - -#define E_Collect '\107' /* Garbage collection */ -#define E_EndCollect '\360' /* End of garbage collection */ -#define E_TenureString '\361' /* Tenure a string region */ -#define E_TenureBlock '\362' /* Tenure a block region */ - -/* - * Termination Events - */ -#define E_Error '\105' /* Run-time error */ -#define E_Exit '\130' /* Program exit */ - - /* - * I/O events - */ -#define E_MXevent '\370' /* monitor input event */ - -#endif /* EventMon */ diff --git a/src/h/mswin.h b/src/h/mswin.h index 2734cb1..a16ab8a 100644 --- a/src/h/mswin.h +++ b/src/h/mswin.h @@ -132,8 +132,8 @@ } #define EVQUEEMPTY(ws) (BlkLoc((ws)->listp)->list.size == 0) -#define SHARED 0 -#define MUTABLE 1 +#define CSHARED 0 +#define CMUTABLE 1 #define MAXCOLORNAME 40 /* * color structure, inspired by X code (xwin.h) @@ -142,7 +142,7 @@ typedef struct wcolor { int refcount; char name[6+MAXCOLORNAME]; /* name for WAttrib & WColor reads */ SysColor c; - int type; /* SHARED or MUTABLE */ + int type; /* CSHARED or CMUTABLE */ } *wclrp; /* diff --git a/src/h/rexterns.h b/src/h/rexterns.h index 804424c..026bdaa 100644 --- a/src/h/rexterns.h +++ b/src/h/rexterns.h @@ -56,133 +56,91 @@ extern struct tend_desc *tend; /* chain of tended descriptors */ /* * Externals that are conditional on features. */ -#ifdef FncTrace - extern struct descrip kywd_ftrc; /* descriptor for &ftrace */ -#endif /* FncTrace */ - #ifdef Polling extern int pollctr; #endif /* Polling */ -#ifdef EventMon - extern char typech[]; - extern word oldsum; - extern struct descrip csetdesc; /* cset descriptor */ - extern struct descrip eventdesc; /* event descriptor */ - extern struct b_iproc mt_llist; - extern struct descrip rzerodesc; /* real descriptor */ - extern struct b_real realzero; /* real zero block */ -#endif /* EventMon */ - /* - * Externals conditional on multithreading. + * Externals that were conditional on multithreading. */ - extern struct region rootstring; - extern struct region rootblock; -#ifndef MultiThread - extern dptr glbl_argp; /* argument pointer */ - extern struct region *curstring; - extern struct region *curblock; - extern struct descrip k_current; /* ¤t */ - extern char *k_errortext; /* value of &errortext */ - extern int have_errval; /* &errorvalue has a legal value */ - extern int k_errornumber; /* value of &errornumber */ - extern int t_errornumber; /* tentative k_errornumber value */ - extern int t_have_val; /* tentative have_errval flag */ - extern struct b_file k_errout; /* value of &errout */ - extern struct b_file k_input; /* value of &input */ - extern struct b_file k_output; /* value of &output */ - extern struct descrip k_errorvalue; /* value of &errorvalue */ - extern struct descrip kywd_err; /* &error */ - extern struct descrip kywd_pos; /* descriptor for &pos */ - extern struct descrip kywd_prog; /* descriptor for &prog */ - extern struct descrip kywd_ran; /* descriptor for &random */ - extern struct descrip k_subject; /* &subject */ - extern struct descrip kywd_trc; /* descriptor for &trace */ - extern struct descrip k_eventcode; /* &eventcode */ - extern struct descrip k_eventsource; /* &eventsource */ - extern struct descrip k_eventvalue; /* &eventvalue */ - extern struct descrip k_main; /* value of &main */ - extern struct descrip t_errorvalue; /* tentative k_errorvalue value */ - extern uword blktotal; /* cumul total of all block allocs */ - extern uword strtotal; /* cumul total of all string allocs */ - extern word coll_tot; /* total number of collections */ - extern word coll_stat; /* collections from static reqests */ - extern word coll_str; /* collections from string requests */ - extern word coll_blk; /* collections from block requests */ - extern dptr globals; /* start of global variables */ - extern dptr eglobals; /* end of global variables */ - extern dptr gnames; /* start of global variable names */ - extern dptr egnames; /* end of global variable names */ - extern dptr estatics; /* end of static variables */ - extern int n_globals; /* number of global variables */ - extern int n_statics; /* number of static variables */ - extern struct b_coexpr *mainhead; /* &main */ -#endif /* MultiThread */ +extern struct region rootstring; +extern struct region rootblock; +extern dptr glbl_argp; /* argument pointer */ +extern struct region *curstring; +extern struct region *curblock; +extern struct descrip k_current; /* ¤t */ +extern char *k_errortext; /* value of &errortext */ +extern int have_errval; /* &errorvalue has a legal value */ +extern int k_errornumber; /* value of &errornumber */ +extern int t_errornumber; /* tentative k_errornumber value */ +extern int t_have_val; /* tentative have_errval flag */ +extern struct b_file k_errout; /* value of &errout */ +extern struct b_file k_input; /* value of &input */ +extern struct b_file k_output; /* value of &output */ +extern struct descrip k_errorvalue; /* value of &errorvalue */ +extern struct descrip kywd_err; /* &error */ +extern struct descrip kywd_pos; /* descriptor for &pos */ +extern struct descrip kywd_prog; /* descriptor for &prog */ +extern struct descrip kywd_ran; /* descriptor for &random */ +extern struct descrip k_subject; /* &subject */ +extern struct descrip kywd_trc; /* descriptor for &trace */ +extern struct descrip k_eventcode; /* &eventcode */ +extern struct descrip k_eventsource; /* &eventsource */ +extern struct descrip k_eventvalue; /* &eventvalue */ +extern struct descrip k_main; /* value of &main */ +extern struct descrip t_errorvalue; /* tentative k_errorvalue value */ +extern uword blktotal; /* cumul total of all block allocs */ +extern uword strtotal; /* cumul total of all string allocs */ +extern word coll_tot; /* total number of collections */ +extern word coll_stat; /* collections from static reqests */ +extern word coll_str; /* collections from string requests */ +extern word coll_blk; /* collections from block requests */ +extern dptr globals; /* start of global variables */ +extern dptr eglobals; /* end of global variables */ +extern dptr gnames; /* start of global variable names */ +extern dptr egnames; /* end of global variable names */ +extern dptr estatics; /* end of static variables */ +extern int n_globals; /* number of global variables */ +extern int n_statics; /* number of static variables */ +extern struct b_coexpr *mainhead; /* &main */ /* - * Externals that differ between compiler and interpreter. + * External declarations that differed for the compiler. */ -#if !COMPILER - /* - * External declarations for the interpreter. - */ - - extern int ixinited; /* iconx has initialized */ - extern inst ipc; /* interpreter program counter */ - extern int ilevel; /* interpreter level */ - extern int ntended; /* number of active tended descriptors*/ - extern struct b_cset k_ascii; /* value of &ascii */ - extern struct b_cset k_cset; /* value of &cset */ - extern struct b_cset k_digits; /* value of &lcase */ - extern struct b_cset k_lcase; /* value of &lcase */ - extern struct b_cset k_letters; /* value of &letters */ - extern struct b_cset k_ucase; /* value of &ucase */ - extern struct descrip tended[]; /* tended descriptors */ - extern struct ef_marker *efp; /* expression frame pointer */ - extern struct gf_marker *gfp; /* generator frame pointer */ - extern struct pf_marker *pfp; /* procedure frame pointer */ - extern word *sp; /* interpreter stack pointer */ - extern word *stack; /* interpreter stack base */ - extern word *stackend; /* end of evaluation stack */ - - extern struct pstrnm pntab[]; - extern int pnsize; - - #ifdef MultiThread - extern struct progstate *curpstate; - extern struct progstate rootpstate; - extern int noMTevents; /* no MT events during GC */ - #else /* MultiThread */ - extern char *code; /* start of icode */ - extern char *ecode; /* end of icode */ - extern dptr statics; /* start of static variables */ - extern char *strcons; /* start of the string constants */ - extern dptr fnames; /* field names */ - extern dptr efnames; /* end of field names */ - extern word *records; - extern int *ftabp; /* field table pointer */ - #ifdef FieldTableCompression - extern word ftabwidth, foffwidth; - extern unsigned char *ftabcp; - extern short *ftabsp; - #endif /* FieldTableCompression */ - extern dptr xargp; - extern word xnargs; - - extern word lastop; - #endif /* MultiThread */ - -#else /* COMPILER */ - - extern struct descrip statics[]; /* array of static variables */ - extern struct b_proc *builtins[]; /* pointers to builtin functions */ - extern int noerrbuf; /* error buffering */ - extern struct p_frame *pfp; /* procedure frame pointer */ - extern struct descrip trashcan; /* dummy descriptor, never read */ - extern int largeints; /* flag: large integers supported */ - -#endif /* COMPILER */ + +extern int ixinited; /* iconx has initialized */ +extern inst ipc; /* interpreter program counter */ +extern int ilevel; /* interpreter level */ +extern int ntended; /* number of active tended descriptors*/ +extern struct b_cset k_ascii; /* value of &ascii */ +extern struct b_cset k_cset; /* value of &cset */ +extern struct b_cset k_digits; /* value of &lcase */ +extern struct b_cset k_lcase; /* value of &lcase */ +extern struct b_cset k_letters; /* value of &letters */ +extern struct b_cset k_ucase; /* value of &ucase */ +extern struct descrip tended[]; /* tended descriptors */ +extern struct ef_marker *efp; /* expression frame pointer */ +extern struct gf_marker *gfp; /* generator frame pointer */ +extern struct pf_marker *pfp; /* procedure frame pointer */ +extern word *sp; /* interpreter stack pointer */ +extern word *stack; /* interpreter stack base */ +extern word *stackend; /* end of evaluation stack */ + +extern struct pstrnm pntab[]; +extern int pnsize; + +extern char *code; /* start of icode */ +extern char *ecode; /* end of icode */ +extern dptr statics; /* start of static variables */ +extern char *strcons; /* start of the string constants */ +extern dptr fnames; /* field names */ +extern dptr efnames; /* end of field names */ +extern word *records; +extern int *ftabp; /* field table pointer */ +extern dptr xargp; +extern word xnargs; + +extern word lastop; /* * graphics @@ -198,7 +156,6 @@ extern struct tend_desc *tend; /* chain of tended descriptors */ extern int win_highwater, canvas_serial, context_serial; extern clock_t starttime; /* start time in milliseconds */ - #ifndef MultiThread extern struct descrip kywd_xwin[]; extern struct descrip lastEventWin; extern int lastEvFWidth, lastEvLeading, lastEvAscent; @@ -208,7 +165,6 @@ extern struct tend_desc *tend; /* chain of tended descriptors */ extern struct descrip amperY; extern struct descrip amperInterval; extern uword xmod_control, xmod_shift, xmod_meta; - #endif /* MultiThread */ #ifdef XWindows extern struct _wdisplay * wdsplys; diff --git a/src/h/rmacros.h b/src/h/rmacros.h index cce26dd..ac9ca64 100644 --- a/src/h/rmacros.h +++ b/src/h/rmacros.h @@ -276,11 +276,7 @@ #define T_String -1 /* string -- for reference; not used */ #define T_Null 0 /* null value */ #define T_Integer 1 /* integer */ - -#ifdef LargeInts - #define T_Lrgint 2 /* long integer */ -#endif /* LargeInts */ - +#define T_Lrgint 2 /* long integer */ #define T_Real 3 /* real number */ #define T_Cset 4 /* cset */ #define T_File 5 /* file */ @@ -316,21 +312,13 @@ #define k_trace kywd_trc.vword.integr /* value of &trace */ #define k_dump kywd_dmp.vword.integr /* value of &dump */ -#ifdef FncTrace - #define k_ftrace kywd_ftrc.vword.integr /* value of &ftrace */ -#endif /* FncTrace */ - /* * Descriptor types and flags. */ #define D_Null (T_Null | D_Typecode) #define D_Integer (T_Integer | D_Typecode) - -#ifdef LargeInts - #define D_Lrgint (T_Lrgint | D_Typecode | F_Ptr) -#endif /* LargeInts */ - +#define D_Lrgint (T_Lrgint | D_Typecode | F_Ptr) #define D_Real (T_Real | D_Typecode | F_Ptr) #define D_Cset (T_Cset | D_Typecode | F_Ptr) #define D_File (T_File | D_Typecode | F_Ptr) @@ -402,284 +390,148 @@ #define blkend (curblock->end) #define blkfree (curblock->free) -#if COMPILER - - #ifdef Graphics - #define Poll() if (!pollctr--) pollctr = pollevent() - #else /* Graphics */ - #define Poll() - #endif /* Graphics */ - -#else /* COMPILER */ - - /* - * Definitions for the interpreter. - */ - - /* - * Codes returned by invoke to indicate action. - */ - #define I_Builtin 201 /* A built-in routine is to be invoked */ - #define I_Fail 202 /* goal-directed evaluation failed */ - #define I_Continue 203 /* Continue execution in the interp loop */ - #define I_Vararg 204 /* A function with a variable number of args */ - - /* - * Generator types. - */ - #define G_Csusp 1 - #define G_Esusp 2 - #define G_Psusp 3 - #define G_Fsusp 4 - #define G_Osusp 5 - - /* - * Evaluation stack overflow margin - */ - #define PerilDelta 100 +/* + * Codes returned by invoke to indicate action. + */ +#define I_Builtin 201 /* A built-in routine is to be invoked */ +#define I_Fail 202 /* goal-directed evaluation failed */ +#define I_Continue 203 /* Continue execution in the interp loop */ +#define I_Vararg 204 /* A function with a variable number of args */ - /* - * Macros for pushing values on the interpreter stack. - */ +/* + * Generator types. + */ +#define G_Csusp 1 +#define G_Esusp 2 +#define G_Psusp 3 +#define G_Fsusp 4 +#define G_Osusp 5 - /* - * Push descriptor. - */ - #define PushDescSP(SP,d) {*++SP=((d).dword); SP++; *SP =((d).vword.integr);} +/* + * Evaluation stack overflow margin + */ +#define PerilDelta 100 - /* - * Push null-valued descriptor. - */ - #define PushNullSP(SP) {*++SP = D_Null; SP++; *SP = 0;} +/* + * Macros for pushing values on the interpreter stack. + */ - /* - * Push word. - */ - #define PushValSP(SP,v) {*++SP = (word)(v);} +/* + * Push descriptor. + */ +#define PushDescSP(SP,d) {*++SP=((d).dword); SP++; *SP =((d).vword.integr);} - /* - * Shorter Versions of the Push*SP macros that assume sp points to the top - * of the stack. - */ - #define PushDesc(d) PushDescSP(sp,d) - #define PushNull PushNullSP(sp) - #define PushVal(x) PushValSP(sp,x) - #define PushAVal(x) PushValSP(sp,x) +/* + * Push null-valued descriptor. + */ +#define PushNullSP(SP) {*++SP = D_Null; SP++; *SP = 0;} - /* - * Macros related to function and operator definition. - */ +/* + * Push word. + */ +#define PushValSP(SP,v) {*++SP = (word)(v);} - /* - * Procedure block for a function. - */ +/* + * Shorter Versions of the Push*SP macros that assume sp points to the top + * of the stack. + */ +#define PushDesc(d) PushDescSP(sp,d) +#define PushNull PushNullSP(sp) +#define PushVal(x) PushValSP(sp,x) +#define PushAVal(x) PushValSP(sp,x) - #define FncBlock(f,nargs,deref) \ - struct b_iproc Cat(B,f) = {\ - T_Proc,\ - Vsizeof(struct b_proc),\ - Cat(Z,f),\ - nargs,\ - -1,\ - deref, 0,\ - {sizeof(Lit(f))-1,Lit(f)}}; +/* + * Macros related to function and operator definition. + */ - /* - * Procedure block for an operator. - */ - #define OpBlock(f,nargs,sname,xtrargs)\ - struct b_iproc Cat(B,f) = {\ - T_Proc,\ - Vsizeof(struct b_proc),\ - Cat(O,f),\ - nargs,\ - -1,\ - xtrargs,\ - 0,\ - {sizeof(sname)-1,sname}}; +/* + * Procedure block for a function. + */ - /* - * Operator declaration. - */ - #define OpDcl(nm,n,pn) OpBlock(nm,n,pn,0) Cat(O,nm)(cargp) register dptr cargp; +#define FncBlock(f,nargs,deref) \ + struct b_iproc Cat(B,f) = {\ + T_Proc,\ + Vsizeof(struct b_proc),\ + Cat(Z,f),\ + nargs,\ + -1,\ + deref, 0,\ + {sizeof(Lit(f))-1,Lit(f)}}; - /* - * Operator declaration with extra working argument. - */ - #define OpDclE(nm,n,pn) OpBlock(nm,-n,pn,0) Cat(O,nm)(cargp) register dptr cargp; +/* + * Procedure block for an operator. + */ +#define OpBlock(f,nargs,sname,xtrargs)\ + struct b_iproc Cat(B,f) = {\ + T_Proc,\ + Vsizeof(struct b_proc),\ + Cat(O,f),\ + nargs,\ + -1,\ + xtrargs,\ + 0,\ + {sizeof(sname)-1,sname}}; - /* - * Agent routine declaration. - */ - #define AgtDcl(nm) Cat(A,nm)(cargp) register dptr cargp; +/* + * Operator declaration. + */ +#define OpDcl(nm,n,pn) OpBlock(nm,n,pn,0) Cat(O,nm)(cargp) register dptr cargp; - /* - * Macros to access Icon arguments in C functions. - */ +/* + * Operator declaration with extra working argument. + */ +#define OpDclE(nm,n,pn) OpBlock(nm,-n,pn,0) Cat(O,nm)(cargp) register dptr cargp; - /* - * n-th argument. - */ - #define Arg(n) (cargp[n]) +/* + * Agent routine declaration. + */ +#define AgtDcl(nm) Cat(A,nm)(cargp) register dptr cargp; - /* - * Type field of n-th argument. - */ - #define ArgType(n) (cargp[n].dword) +/* + * Macros to access Icon arguments in C functions. + */ - /* - * Value field of n-th argument. - */ - #define ArgVal(n) (cargp[n].vword.integr) +/* + * n-th argument. + */ +#define Arg(n) (cargp[n]) - /* - * Specific arguments. - */ - #define Arg0 (cargp[0]) - #define Arg1 (cargp[1]) - #define Arg2 (cargp[2]) - #define Arg3 (cargp[3]) - #define Arg4 (cargp[4]) - #define Arg5 (cargp[5]) - #define Arg6 (cargp[6]) - #define Arg7 (cargp[7]) - #define Arg8 (cargp[8]) +/* + * Type field of n-th argument. + */ +#define ArgType(n) (cargp[n].dword) - /* - * Miscellaneous macro definitions. - */ +/* + * Value field of n-th argument. + */ +#define ArgVal(n) (cargp[n].vword.integr) - #ifdef MultiThread - #define glbl_argp (curpstate->Glbl_argp) - #define kywd_err (curpstate->Kywd_err) - #define kywd_pos (curpstate->Kywd_pos) - #define kywd_prog (curpstate->Kywd_prog) - #define kywd_ran (curpstate->Kywd_ran) - #define k_eventcode (curpstate->eventcode) - #define k_eventsource (curpstate->eventsource) - #define k_eventvalue (curpstate->eventval) - #define k_subject (curpstate->ksub) - #define kywd_trc (curpstate->Kywd_trc) - #define mainhead (curpstate->Mainhead) - #define code (curpstate->Code) - #define ecode (curpstate->Ecode) - #define records (curpstate->Records) - #define ftabp (curpstate->Ftabp) - #ifdef FieldTableCompression - #define ftabwidth (curpstate->Ftabwidth) - #define foffwidth (curpstate->Foffwidth) - #define ftabcp (curpstate->Ftabcp) - #define ftabsp (curpstate->Ftabsp) - #define focp (curpstate->Focp) - #define fosp (curpstate->Fosp) - #define fo (curpstate->Fo) - #define bm (curpstate->Bm) - #endif /* FieldTableCompression */ - #define fnames (curpstate->Fnames) - #define efnames (curpstate->Efnames) - #define globals (curpstate->Globals) - #define eglobals (curpstate->Eglobals) - #define gnames (curpstate->Gnames) - #define egnames (curpstate->Egnames) - #define statics (curpstate->Statics) - #define estatics (curpstate->Estatics) - #define n_globals (curpstate->NGlobals) - #define n_statics (curpstate->NStatics) - #define strcons (curpstate->Strcons) - #define filenms (curpstate->Filenms) - #define efilenms (curpstate->Efilenms) - #define ilines (curpstate->Ilines) - #define elines (curpstate->Elines) - #define current_line_ptr (curpstate->Current_line_ptr) - - #ifdef Graphics - #define amperX (curpstate->AmperX) - #define amperY (curpstate->AmperY) - #define amperRow (curpstate->AmperRow) - #define amperCol (curpstate->AmperCol) - #define amperInterval (curpstate->AmperInterval) - #define lastEventWin (curpstate->LastEventWin) - #define lastEvFWidth (curpstate->LastEvFWidth) - #define lastEvLeading (curpstate->LastEvLeading) - #define lastEvAscent (curpstate->LastEvAscent) - #define kywd_xwin (curpstate->Kywd_xwin) - #define xmod_control (curpstate->Xmod_Control) - #define xmod_shift (curpstate->Xmod_Shift) - #define xmod_meta (curpstate->Xmod_Meta) - #endif /* Graphics */ - - #ifdef EventMon - #define linenum (curpstate->Linenum) - #define column (curpstate->Column) - #define lastline (curpstate->Lastline) - #define lastcol (curpstate->Lastcol) - #endif /* EventMon */ - - #define coexp_ser (curpstate->Coexp_ser) - #define list_ser (curpstate->List_ser) - #define set_ser (curpstate->Set_ser) - #define table_ser (curpstate->Table_ser) - - #define curstring (curpstate->stringregion) - #define curblock (curpstate->blockregion) - #define strtotal (curpstate->stringtotal) - #define blktotal (curpstate->blocktotal) - - #define coll_tot (curpstate->colltot) - #define coll_stat (curpstate->collstat) - #define coll_str (curpstate->collstr) - #define coll_blk (curpstate->collblk) - - #define lastop (curpstate->Lastop) - #define lastopnd (curpstate->Lastopnd) - - #define xargp (curpstate->Xargp) - #define xnargs (curpstate->Xnargs) - - #define k_current (curpstate->K_current) - #define k_errornumber (curpstate->K_errornumber) - #define k_errortext (curpstate->K_errortext) - #define k_errorvalue (curpstate->K_errorvalue) - #define have_errval (curpstate->Have_errval) - #define t_errornumber (curpstate->T_errornumber) - #define t_have_val (curpstate->T_have_val) - #define t_errorvalue (curpstate->T_errorvalue) - - #define k_main (curpstate->K_main) - #define k_errout (curpstate->K_errout) - #define k_input (curpstate->K_input) - #define k_output (curpstate->K_output) - - #define ENTERPSTATE(p) if (((p)!=NULL)) { curpstate = (p); } - #endif /* MultiThread */ - -#endif /* COMPILER */ +/* + * Specific arguments. + */ +#define Arg0 (cargp[0]) +#define Arg1 (cargp[1]) +#define Arg2 (cargp[2]) +#define Arg3 (cargp[3]) +#define Arg4 (cargp[4]) +#define Arg5 (cargp[5]) +#define Arg6 (cargp[6]) +#define Arg7 (cargp[7]) +#define Arg8 (cargp[8]) /* * Constants controlling expression evaluation. */ -#if COMPILER - #define A_Resume -1 /* expression failed: resume a generator */ - #define A_Continue -2 /* expression returned: continue execution */ - #define A_FallThru -3 /* body function: fell through end of code */ - #define A_Coact 1 /* co-expression activation */ - #define A_Coret 2 /* co-expression return */ - #define A_Cofail 3 /* co-expression failure */ -#else /* COMPILER */ - #define A_Resume 1 /* routine failed */ - #define A_Pret_uw 2 /* interp unwind for Op_Pret */ - #define A_Unmark_uw 3 /* interp unwind for Op_Unmark */ - #define A_Pfail_uw 4 /* interp unwind for Op_Pfail */ - #define A_Lsusp_uw 5 /* interp unwind for Op_Lsusp */ - #define A_Eret_uw 6 /* interp unwind for Op_Eret */ - #define A_Continue 7 /* routine returned */ - #define A_Coact 8 /* co-expression activated */ - #define A_Coret 9 /* co-expression returned */ - #define A_Cofail 10 /* co-expression failed */ - #ifdef MultiThread - #define A_MTEvent 11 /* multithread event */ - #endif /* MultiThread */ -#endif /* COMPILER */ +#define A_Resume 1 /* routine failed */ +#define A_Pret_uw 2 /* interp unwind for Op_Pret */ +#define A_Unmark_uw 3 /* interp unwind for Op_Unmark */ +#define A_Pfail_uw 4 /* interp unwind for Op_Pfail */ +#define A_Lsusp_uw 5 /* interp unwind for Op_Lsusp */ +#define A_Eret_uw 6 /* interp unwind for Op_Eret */ +#define A_Continue 7 /* routine returned */ +#define A_Coact 8 /* co-expression activated */ +#define A_Coret 9 /* co-expression returned */ +#define A_Cofail 10 /* co-expression failed */ /* * Address of word containing cset bit b (c is a struct descrip of type Cset). diff --git a/src/h/rproto.h b/src/h/rproto.h index 3a5cc30..6394726 100644 --- a/src/h/rproto.h +++ b/src/h/rproto.h @@ -46,7 +46,7 @@ void coclean (word *old); void coacttrace (struct b_coexpr *ccp,struct b_coexpr *ncp); void cofailtrace (struct b_coexpr *ccp,struct b_coexpr *ncp); void corettrace (struct b_coexpr *ccp,struct b_coexpr *ncp); -int coswitch (word *old, word *new, int first); +int coswitch (word *oldctx, word *newctx, int firsttime); int cplist (dptr dp1,dptr dp2,word i,word j); int cpset (dptr dp1,dptr dp2,word size); void cpslots (dptr dp1,dptr slotptr,word i, word j); @@ -116,7 +116,8 @@ int qtos (dptr dp,char *sbuf); int radix (int sign, register int r, register char *s, register char *end_s, union numeric *result); char *reserve (int region, word nbytes); -void retderef (dptr valp, word *low, word *high); +void resolve (void); +void retderef (dptr valp, word *low, word *high); void segvtrap (int); void stkdump (int); word sub (word a,word b); @@ -124,49 +125,31 @@ void syserr (char *s); struct b_coexpr *topact (struct b_coexpr *ce); void xmfree (void); -#ifdef MultiThread - void resolve (struct progstate *pstate); - struct b_coexpr *loadicode (char *name, struct b_file *theInput, - struct b_file *theOutput, struct b_file *theError, - C_integer bs, C_integer ss, C_integer stk); - void actparent (int eventcode); - int mt_activate (dptr tvalp, dptr rslt, struct b_coexpr *ncp); -#else /* MultiThread */ - void resolve (void); -#endif /* MultiThread */ - -#ifdef EventMon - void EVAsgn (dptr dx); -#endif /* EventMon */ - -#ifdef ExternalFunctions - dptr extcall (dptr x, int nargs, int *signal); -#endif /* ExternalFunctions */ - -#ifdef LargeInts - struct b_bignum *alcbignum (word n); - word bigradix (int sign, int r, char *s, char *x, +/* + * for large integers + */ +struct b_bignum *alcbignum (word n); +word bigradix (int sign, int r, char *s, char *x, union numeric *result); - double bigtoreal (dptr da); - int realtobig (dptr da, dptr dx); - int bigtos (dptr da, dptr dx); - void bigprint (FILE *f, dptr da); - int cpbignum (dptr da, dptr db); - int bigadd (dptr da, dptr db, dptr dx); - int bigsub (dptr da, dptr db, dptr dx); - int bigmul (dptr da, dptr db, dptr dx); - int bigdiv (dptr da, dptr db, dptr dx); - int bigmod (dptr da, dptr db, dptr dx); - int bigneg (dptr da, dptr dx); - int bigpow (dptr da, dptr db, dptr dx); - int bigpowri (double a, dptr db, dptr drslt); - int bigand (dptr da, dptr db, dptr dx); - int bigor (dptr da, dptr db, dptr dx); - int bigxor (dptr da, dptr db, dptr dx); - int bigshift (dptr da, dptr db, dptr dx); - word bigcmp (dptr da, dptr db); - int bigrand (dptr da, dptr dx); -#endif /* LargeInts */ +double bigtoreal (dptr da); +int realtobig (dptr da, dptr dx); +int bigtos (dptr da, dptr dx); +void bigprint (FILE *f, dptr da); +int cpbignum (dptr da, dptr db); +int bigadd (dptr da, dptr db, dptr dx); +int bigsub (dptr da, dptr db, dptr dx); +int bigmul (dptr da, dptr db, dptr dx); +int bigdiv (dptr da, dptr db, dptr dx); +int bigmod (dptr da, dptr db, dptr dx); +int bigneg (dptr da, dptr dx); +int bigpow (dptr da, dptr db, dptr dx); +int bigpowri (double a, dptr db, dptr drslt); +int bigand (dptr da, dptr db, dptr dx); +int bigor (dptr da, dptr db, dptr dx); +int bigxor (dptr da, dptr db, dptr dx); +int bigshift (dptr da, dptr db, dptr dx); +word bigcmp (dptr da, dptr db); +int bigrand (dptr da, dptr dx); #ifdef FAttrib char *make_mode(mode_t st_mode); @@ -385,10 +368,11 @@ void xmfree (void); * Prototypes for the run-time system. */ -struct b_external *alcextrnl (int n); +struct b_external *alcexternal (long nbytes, struct b_extlfuns *f, void *data); struct b_record *alcrecd (int nflds,union block *recptr); struct b_tvsubs *alcsubs (word len,word pos,dptr var); int bfunc (void); +struct descrip callextfunc (int (*)(int, dptr), dptr, dptr); long ckadd (long i, long j); long ckmul (long i, long j); long cksub (long i, long j); @@ -401,6 +385,10 @@ int cvcset (dptr dp,int * *cs,int *csbuf); int cvnum (dptr dp,union numeric *result); int cvreal (dptr dp,double *r); void deref (dptr dp1, dptr dp2); +int extlcmp (int argc, dptr argv); +int extlcopy (int argc, dptr argv); +int extlimage (int argc, dptr argv); +int extlname (int argc, dptr argv); void envset (void); int eq (dptr dp1,dptr dp2); int get_name (dptr dp1, dptr dp2); @@ -432,50 +420,25 @@ int tvcmp4 (struct dpair *dp1,struct dpair *dp2); int tvtbl_asgn (dptr dest, const dptr src); void varargs (dptr argp, int nargs, dptr rslt); -#ifdef MultiThread - struct b_coexpr *alccoexp (long icodesize, long stacksize); -#else /* MultiThread */ - struct b_coexpr *alccoexp (void); -#endif /* MultiThread */ - -#if COMPILER - - struct b_refresh *alcrefresh (int na, int nl, int nt, int wk_sz); - void atrace (void); - void ctrace (void); - void failtrace (void); - void initalloc (void); - int invoke (int n, dptr args, dptr rslt, continuation c); - void rtrace (void); - void strace (void); - void tracebk (struct p_frame *lcl_pfp, dptr argp); - int xdisp (struct p_frame *fp, dptr dp, int n, FILE *f); - -#else /* COMPILER */ - - struct b_refresh *alcrefresh (word *e, int nl, int nt); - void atrace (dptr dp); - void ctrace (dptr dp, int nargs, dptr arg); - void failtrace (dptr dp); - int invoke (int nargs, dptr *cargs, int *n); - void rtrace (dptr dp, dptr rval); - void strace (dptr dp, dptr rval); - void tracebk (struct pf_marker *lcl_pfp, dptr argp); - int xdisp (struct pf_marker *fp, dptr dp, int n, FILE *f); +struct b_coexpr *alccoexp (void); - #define Fargs dptr cargp - int Obscan (int nargs, Fargs); - int Ocreate (word *entryp, Fargs); - int Oescan (int nargs, Fargs); - int Ofield (int nargs, Fargs); - int Olimit (int nargs, Fargs); - int Ollist (int nargs, Fargs); - int Omkrec (int nargs, Fargs); +struct b_refresh *alcrefresh (word *e, int nl, int nt); +void atrace (dptr dp); +void ctrace (dptr dp, int nargs, dptr arg); +void failtrace (dptr dp); +int invoke (int nargs, dptr *cargs, int *n); +void rtrace (dptr dp, dptr rval); +void strace (dptr dp, dptr rval); +void tracebk (struct pf_marker *lcl_pfp, dptr argp); +int xdisp (struct pf_marker *fp, dptr dp, int n, FILE *f); - #ifdef MultiThread - void initalloc (word codesize, struct progstate *p); - #else /* MultiThread */ - void initalloc (word codesize); - #endif /* MultiThread */ +#define Fargs dptr cargp +int Obscan (int nargs, Fargs); +int Ocreate (word *entryp, Fargs); +int Oescan (int nargs, Fargs); +int Ofield (int nargs, Fargs); +int Olimit (int nargs, Fargs); +int Ollist (int nargs, Fargs); +int Omkrec (int nargs, Fargs); -#endif /* COMPILER */ +void initalloc (word codesize); diff --git a/src/h/rstructs.h b/src/h/rstructs.h index 5ee3fbb..9b32dd5 100644 --- a/src/h/rstructs.h +++ b/src/h/rstructs.h @@ -17,7 +17,6 @@ struct errtab { /* * Descriptor */ - struct descrip { /* descriptor */ word dword; /* type field */ union { @@ -33,7 +32,10 @@ struct sdescrip { char *string; /* pointer to string */ }; -#ifdef LargeInts +/* + * Heap Blocks + */ + struct b_bignum { /* large integer block */ word title; /* T_Lrgint */ word blksize; /* block size */ @@ -41,7 +43,6 @@ struct b_bignum { /* large integer block */ int sign; /* sign; 0 positive, 1 negative */ DIGIT digits[1]; /* digits */ }; -#endif /* LargeInts */ struct b_real { /* real block */ word title; /* T_Real */ @@ -83,16 +84,11 @@ struct b_list { /* list-header block */ struct b_proc { /* procedure block */ word title; /* T_Proc */ word blksize; /* size of block */ - - #if COMPILER - int (*ccode)(); - #else /* COMPILER */ - union { /* entry points for */ - int (*ccode)(); /* C routines */ - uword ioff; /* and icode as offset */ - pointer icode; /* and icode as absolute pointer */ - } entryp; - #endif /* COMPILER */ + union { /* entry points for */ + int (*ccode)(); /* C routines */ + uword ioff; /* and icode as offset */ + pointer icode; /* and icode as absolute pointer */ + } entryp; word nparam; /* number of parameters */ word ndynam; /* number of dynamic locals */ @@ -178,7 +174,9 @@ struct b_tvtbl { /* table element trapped variable block */ struct b_external { /* external block */ word title; /* T_External */ word blksize; /* size of block */ - word exdata[1]; /* words of external data */ + word id; /* identification number */ + struct b_extlfuns *funcs; /* dispatch table; distinguishes extl types */ + word data[]; /* actual external data */ }; struct astkblk { /* co-expression activator-stack block */ @@ -225,6 +223,17 @@ struct dpair { }; /* + * Structure for dispatching to user-provided C functions + * associated with external data. Any entry can be null. + */ +struct b_extlfuns { + int (*extlcmp) (int argc, dptr argv); + int (*extlcopy) (int argc, dptr argv); + int (*extlname) (int argc, dptr argv); + int (*extlimage)(int argc, dptr argv); + }; + +/* * Allocated memory region structure. Each program has linked lists of * string and block regions. */ @@ -246,20 +255,6 @@ struct region { }; #endif /* Double */ -#if COMPILER - -/* - * Structures for the compiler. - */ - struct p_frame { - struct p_frame *old_pfp; - struct descrip *old_argp; - struct descrip *rslt; - continuation succ_cont; - struct tend_desc tend; - }; - #endif /* COMPILER */ - /* * when debugging is enabled a debug struct is placed after the tended * descriptors in the procedure frame. @@ -273,46 +268,9 @@ struct debug { union numeric { /* long integers or real numbers */ long integer; double real; - #ifdef LargeInts - struct b_bignum *big; - #endif /* LargeInts */ - }; - -#if COMPILER -struct b_coexpr { /* co-expression stack block */ - word title; /* T_Coexpr */ - word size; /* number of results produced */ - word id; /* identification number */ - struct b_coexpr *nextstk; /* pointer to next allocated stack */ - continuation fnc; /* function containing co-expression code */ - struct p_frame *es_pfp; /* current procedure frame pointer */ - dptr es_argp; /* current argument pointer */ - struct tend_desc *es_tend; /* current tended pointer */ - char *file_name; /* current file name */ - word line_num; /* current line_number */ - dptr tvalloc; /* where to place transmitted value */ - struct descrip freshblk; /* refresh block pointer */ - struct astkblk *es_actstk; /* pointer to activation stack structure */ - word cstate[CStateSize]; /* C state information */ - struct p_frame pf; /* initial procedure frame */ - }; - -struct b_refresh { /* co-expression block */ - word title; /* T_Refresh */ - word blksize; /* size of block */ - word nlocals; /* number of local variables */ - word nargs; /* number of arguments */ - word ntemps; /* number of temporary descriptors */ - word wrk_size; /* size of non-descriptor work area */ - struct descrip elems[1]; /* locals and arguments */ + struct b_bignum *big; }; -#else /* COMPILER */ - -/* - * Structures for the interpreter. - */ - /* * Declarations for entries in tables associating icode location with * source program location. @@ -327,105 +285,6 @@ struct ipc_line { int line; /* line number */ }; -#ifdef MultiThread -/* - * Program state encapsulation. This consists of the VARIABLE parts of - * many global structures. - */ -struct progstate { - long hsize; /* size of the icode */ - struct progstate *parent; - struct descrip parentdesc; /* implicit "&parent" */ - struct descrip eventmask; /* implicit "&eventmask" */ - struct descrip opcodemask; /* implicit "&opcodemask" */ - struct descrip eventcode; /* &eventcode */ - struct descrip eventval; /* &eventval */ - struct descrip eventsource; /* &eventsource */ - dptr Glbl_argp; /* global argp */ - - /* - * trapped variable keywords' values - */ - struct descrip Kywd_err; - struct descrip Kywd_pos; - struct descrip ksub; - struct descrip Kywd_prog; - struct descrip Kywd_ran; - struct descrip Kywd_trc; - struct b_coexpr *Mainhead; - char *Code; - char *Ecode; - word *Records; - int *Ftabp; - #ifdef FieldTableCompression - short Ftabwidth, Foffwidth; - unsigned char *Ftabcp, *Focp; - short *Ftabsp, *Fosp; - int *Fo; - char *Bm; - #endif /* FieldTableCompression */ - dptr Fnames, Efnames; - dptr Globals, Eglobals; - dptr Gnames, Egnames; - dptr Statics, Estatics; - int NGlobals, NStatics; - char *Strcons; - struct ipc_fname *Filenms, *Efilenms; - struct ipc_line *Ilines, *Elines; - struct ipc_line * Current_line_ptr; - - #ifdef Graphics - struct descrip AmperX, AmperY, AmperRow, AmperCol;/* &x, &y, &row, &col */ - struct descrip AmperInterval; /* &interval */ - struct descrip LastEventWin; /* last Event() win */ - int LastEvFWidth; - int LastEvLeading; - int LastEvAscent; - uword PrevTimeStamp; /* previous timestamp */ - uword Xmod_Control, Xmod_Shift, Xmod_Meta; /* control,shift,meta */ - struct descrip Kywd_xwin[2]; /* &window + ... */ - #endif /* Graphics */ - - #ifdef EventMon - word Linenum, Column, Lastline, Lastcol; - #endif /* EventMon */ - - word Coexp_ser; /* this program's serial numbers */ - word List_ser; - word Set_ser; - word Table_ser; - - uword stringtotal; /* cumulative total allocation */ - uword blocktotal; /* cumulative total allocation */ - word colltot; /* total number of collections */ - word collstat; /* number of static collect requests */ - word collstr; /* number of string collect requests */ - word collblk; /* number of block collect requests */ - struct region *stringregion; - struct region *blockregion; - - word Lastop; - - dptr Xargp; - word Xnargs; - - struct descrip K_current; - int K_errornumber; - char *K_errortext; - struct descrip K_errorvalue; - int Have_errval; - int T_errornumber; - int T_have_val; - struct descrip T_errorvalue; - - struct descrip K_main; - struct b_file K_errout; - struct b_file K_input; - struct b_file K_output; - }; - -#endif /* MultiThread */ - /* * Frame markers */ @@ -445,11 +304,6 @@ struct pf_marker { /* procedure frame marker */ inst pf_ipc; /* saved ipc */ word pf_ilevel; /* saved ilevel */ dptr pf_scan; /* saved scanning environment */ - - #ifdef MultiThread - struct progstate *pf_prog;/* saved program state pointer */ - #endif /* MultiThread */ - struct descrip pf_locals[1]; /* descriptors for locals */ }; @@ -511,12 +365,7 @@ struct b_coexpr { /* co-expression stack block */ dptr tvalloc; /* where to place transmitted value */ struct descrip freshblk; /* refresh block pointer */ struct astkblk *es_actstk; /* pointer to activation stack structure */ - - #ifdef MultiThread - struct progstate *program; - #endif /* MultiThread */ - - word cstate[CStateSize]; /* C state information */ + word cstate[2]; /* was C state, now rswitch data */ }; struct b_refresh { /* co-expression block */ @@ -528,7 +377,6 @@ struct b_refresh { /* co-expression block */ struct descrip elems[1]; /* arguments and locals, including Arg0 */ }; -#endif /* COMPILER */ union block { /* general block */ struct b_real realblk; @@ -548,8 +396,5 @@ union block { /* general block */ struct b_coexpr coexpr; struct b_external externl; struct b_slots slots; - - #ifdef LargeInts - struct b_bignum bignumblk; - #endif /* LargeInts */ + struct b_bignum bignumblk; }; @@ -13,7 +13,6 @@ #include "../h/cstructs.h" #include "../h/mproto.h" #include "../h/cpuconf.h" -#include "../h/monitor.h" #include "../h/rmacros.h" #include "../h/rstructs.h" diff --git a/src/h/sys.h b/src/h/sys.h index fecfd96..b858a7e 100644 --- a/src/h/sys.h +++ b/src/h/sys.h @@ -35,22 +35,22 @@ * Operating-system-dependent includes. */ #if MSWIN - #include <windows.h> - #include <sys/cygwin.h> - #include <sys/select.h> - #ifdef WinGraphics + #include <windows.h> + #include <sys/cygwin.h> + #include <sys/select.h> + #define int_PASCAL int PASCAL #define LRESULT_CALLBACK LRESULT CALLBACK #define BOOL_CALLBACK BOOL CALLBACK #include <mmsystem.h> #include <process.h> #include "../wincap/dibutil.h" - #endif /* WinGraphics */ - #undef Type - #undef lst1 - #undef lst2 + #undef Type + #undef lst1 + #undef lst2 + #endif /* WinGraphics */ #endif /* MSWIN */ /* diff --git a/src/h/typedefs.h b/src/h/typedefs.h index 984af9a..041a1f7 100644 --- a/src/h/typedefs.h +++ b/src/h/typedefs.h @@ -39,43 +39,35 @@ typedef word C_integer; */ typedef int (*continuation) (void); -#if !COMPILER - - /* - * Typedefs for the interpreter. - */ - - /* - * Icode consists of operators and arguments. Operators are small integers, - * while arguments may be pointers. To conserve space in icode files on - * computers with 16-bit ints, icode is written by the linker as a mixture - * of ints and words (longs). When an icode file is read in and processed - * by the interpreter, it looks like a C array of mixed ints and words. - * Accessing this "nonstandard" structure is handled by a union of int and - * word pointers and incrementing is done by incrementing the appropriate - * member of the union (see the interpreter). This is a rather dubious - * method and certainly not portable. A better way might be to address - * icode with a char *, but the incrementing code might be inefficient - * (at a place that experiences a lot of execution activity). - * - * For the moment, the dubious coding is isolated under control of the - * size of integers. - */ - - #if IntBits != WordBits +/* + * Icode consists of operators and arguments. Operators are small integers, + * while arguments may be pointers. To conserve space in icode files on + * computers with 16-bit ints, icode is written by the linker as a mixture + * of ints and words (longs). When an icode file is read in and processed + * by the interpreter, it looks like a C array of mixed ints and words. + * Accessing this "nonstandard" structure is handled by a union of int and + * word pointers and incrementing is done by incrementing the appropriate + * member of the union (see the interpreter). This is a rather dubious + * method and certainly not portable. A better way might be to address + * icode with a char *, but the incrementing code might be inefficient + * (at a place that experiences a lot of execution activity). + * + * For the moment, the dubious coding is isolated under control of the + * size of integers. + */ - typedef union { - int *op; - word *opnd; - } inst; +#if IntBits != WordBits - #else /* IntBits != WordBits */ + typedef union { + int *op; + word *opnd; + } inst; - typedef union { - word *op; - word *opnd; - } inst; +#else /* IntBits != WordBits */ - #endif /* IntBits != WordBits */ + typedef union { + word *op; + word *opnd; + } inst; -#endif /* COMPILER */ +#endif /* IntBits != WordBits */ diff --git a/src/h/version.h b/src/h/version.h index c3a8b8d..c7ac2a0 100644 --- a/src/h/version.h +++ b/src/h/version.h @@ -11,8 +11,8 @@ * Icon version number and date. * These are the only two entries that change any more. */ -#define VersionNumber "9.4.3" -#define VersionDate "November 14, 2005" +#define VersionNumber "9.5.0" +#define VersionDate "April 12, 2010" /* * Version number to insure format of data base matches version of iconc @@ -20,47 +20,22 @@ */ #define DVersion "9.0.00" -#if COMPILER - - /* - * &version - */ - #define Version "Icon Version " VersionNumber "-C, " VersionDate - -#else /* COMPILER */ - - /* - * &version - */ - #define Version "Icon Version " VersionNumber ", " VersionDate - - /* - * Version numbers to be sure that ucode is compatible with the linker - * and that icode is compatible with the run-time system. - */ - - #define UVersion "U9.0.00" - - #ifdef FieldTableCompression - - #if IntBits == 32 - #define IVersion "I9.2.00FT/32" - #endif /* IntBits == 32 */ - - #if IntBits == 64 - #define IVersion "I9.2.00FT/64" - #endif /* IntBits == 64 */ - - #else /* FieldTableCompression */ +/* + * &version + */ +#define Version "Icon Version " VersionNumber ", " VersionDate - #if IntBits == 32 - #define IVersion "I9.0.00/32" - #endif /* IntBits == 32 */ +/* + * Version numbers to be sure that ucode is compatible with the linker + * and that icode is compatible with the run-time system. + */ - #if IntBits == 64 - #define IVersion "I9.0.00/64" - #endif /* IntBits == 64 */ +#define UVersion "U9.0.00" - #endif /* FieldTableCompression */ +#if IntBits == 32 + #define IVersion "I9.0.00/32" +#endif /* IntBits == 32 */ -#endif /* COMPILER */ +#if IntBits == 64 + #define IVersion "I9.0.00/64" +#endif /* IntBits == 64 */ diff --git a/src/h/xwin.h b/src/h/xwin.h index a8ff24c..2469747 100644 --- a/src/h/xwin.h +++ b/src/h/xwin.h @@ -74,8 +74,8 @@ #define WMAXCOLORS 256 #define MAXCOLORNAME 40 #define MAXDISPLAYNAME 64 -#define SHARED 0 -#define MUTABLE 1 +#define CSHARED 0 +#define CMUTABLE 1 #define NUMCURSORSYMS 78 /* @@ -165,7 +165,7 @@ typedef struct wcolor { unsigned long c; /* X pixel value */ int refcount; /* reference count */ - int type; /* SHARED or MUTABLE */ + int type; /* CSHARED or CMUTABLE */ int next; /* next entry in hash chain */ unsigned short r, g, b; /* rgb for colorsearch */ char name[6+MAXCOLORNAME]; /* name for WAttrib & WColor reads */ diff --git a/src/iconc/Makefile b/src/iconc/Makefile deleted file mode 100644 index bce6aa8..0000000 --- a/src/iconc/Makefile +++ /dev/null @@ -1,73 +0,0 @@ -# Makefile for the Icon compiler, iconc. -# -# This is no longer supported and may not work. - -include ../../Makedefs - - -OBJS = cmain.o ctrans.o dbase.o clex.o\ - cparse.o csym.o cmem.o ctree.o ccode.o ccomp.o\ - ivalues.o codegen.o fixcode.o inline.o chkinv.o\ - typinfer.o types.o lifetime.o incheck.o - -COBJS = ../common/long.o ../common/getopt.o ../common/time.o\ - ../common/filepart.o ../common/identify.o ../common/munix.o\ - ../common/strtbl.o ../common/rtdb.o ../common/literals.o \ - ../common/alloc.o ../common/ipp.o - - - -iconc: $(OBJS) $(COBJS) - $(CC) -o iconc $(OBJS) $(COBJS) - cp iconc ../../bin - strip ../../bin/iconc$(EXE) - -$(OBJS): ../h/config.h ../h/cpuconf.h ../h/cstructs.h ../h/define.h\ - ../h/mproto.h ../h/typedefs.h ../h/gsupport.h \ - ccode.h cglobals.h cproto.h csym.h ctrans.h ctree.h - -$(COBJS): ../h/mproto.h - cd ../common; $(MAKE); $(MAKE) xpm - -ccode.o: ../h/lexdef.h ctoken.h -chkinv.o: ctoken.h -clex.o: ../h/lexdef.h ../h/parserr.h ctoken.h \ - ../common/lextab.h ../common/yylex.h ../common/error.h -clocal.o: ../h/config.h -cparse.o: ../h/lexdef.h -ctrans.o: ctoken.h -ctree.o: ../h/lexdef.h ctoken.h -csym.o: ctoken.h -dbase.o: ../h/lexdef.h -lifetime.o: ../h/lexdef.h ctoken.h -typinfer.o: ../h/lexdef.h ctoken.h -types.o: ../h/lexdef.h ctoken.h - - - -# The following sections are commented out because they do not need to -# be performed unless changes are made to cgrammar.c, ../h/grammar.h, -# ../common/tokens.txt, or ../common/op.txt. Such changes involve -# modifications to the syntax of Icon and are not part of the installation -# process. However, if the distribution files are unloaded in a fashion -# such that their dates are not set properly, the following sections would -# be attempted. -# -# Note that if any changes are made to the files mentioned above, the comment -# characters at the beginning of the following lines should be removed. -# icont must be on your search path for these actions to work. -# -#../common/lextab.h ../common/yacctok.h ../common/fixgram ../common/pscript: \ -# ../common/tokens.txt ../common/op.txt -# cd ../common; $(MAKE) gfiles -# -#cparse.c ctoken.h: cgram.g ../common/pscript -## expect 218 shift/reduce conflicts -# yacc -d cgram.g -# ../common/pscript <y.tab.c >cparse.c -# mv y.tab.h ctoken.h -# rm -f y.tab.c -# -#cgram.g: cgrammar.c ../h/define.h ../h/grammar.h \ -# ../common/yacctok.h ../common/fixgram -# $(CC) -E -C cgrammar.c | ../common/fixgram >cgram.g diff --git a/src/iconc/ccode.c b/src/iconc/ccode.c deleted file mode 100644 index 108cd15..0000000 --- a/src/iconc/ccode.c +++ /dev/null @@ -1,4954 +0,0 @@ -/* - * ccode.c - routines to produce internal representation of C code. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "cglobals.h" -#include "csym.h" -#include "ccode.h" -#include "ctree.h" -#include "ctoken.h" -#include "cproto.h" - -#ifdef OptimizeLit - -#define NO_LIMIT 0 -#define LIMITED 1 -#define LIMITED_TO_INT 2 -#define NO_TOUCH 3 - -struct lit_tbl { - int modified; - int index; - int safe; - struct code *initial; - struct code *end; - struct val_loc *vloc; - struct centry *csym; - struct lit_tbl *prev; - struct lit_tbl *next; -}; -#endif /* OptimizeLit */ - -/* - * Prototypes for static functions. - */ -static struct c_fnc *alc_fnc (void); -static struct tmplftm *alc_lftm (int num, union field *args); -static int alc_tmp (int n, struct tmplftm *lifetm_ary); - -#ifdef OptimizePoll - static int analyze_poll (void); - static void remove_poll (void); -#endif /* OptimizePoll */ - -#ifdef OptimizeLit - static int instr (const char *str, int chr); - static void invalidate (struct val_loc *val,struct code *end,int code); - static void analyze_literals (struct code *start, struct code *top, int lvl); - static int eval_code (struct code *cd, struct lit_tbl *cur); - static void propagate_literals (void); - static void free_tbl (void); - static struct lit_tbl *alc_tbl (void); - static void tbl_add (truct lit_tbl *add); -#endif /* OptimizeLit */ - -static struct code *asgn_null (struct val_loc *loc1); -static struct val_loc *bound (struct node *n, struct val_loc *rslt, - int catch_fail); -static struct code *check_var (struct val_loc *d, struct code *lbl); -static void deref_cd (struct val_loc *src, struct val_loc *dest); -static void deref_ret (struct val_loc *src, struct val_loc *dest, - int subtypes); -static void endlife (int kind, int indx, int old, nodeptr n); -static struct val_loc *field_ref(struct node *n, struct val_loc *rslt); -static struct val_loc *gen_act (nodeptr n, struct val_loc *rslt); -static struct val_loc *gen_apply(struct node *n, struct val_loc *rslt); -static struct val_loc *gen_args (struct node *n, int frst_arg, int nargs); -static struct val_loc *gen_case (struct node *n, struct val_loc *rslt); -static struct val_loc *gen_creat(struct node *n, struct val_loc *rslt); -static struct val_loc *gen_lim (struct node *n, struct val_loc *rslt); -static struct val_loc *gen_scan (struct node *n, struct val_loc *rslt); -static struct val_loc *gencode (struct node *n, struct val_loc *rslt); -static struct val_loc *genretval(struct node *n, struct node *expr, - struct val_loc *dest); -static struct val_loc *inv_prc (nodeptr n, struct val_loc *rslt); -static struct val_loc *inv_op (nodeptr n, struct val_loc *rslt); -static nodeptr max_lftm (nodeptr n1, nodeptr n2); -static void mk_callop (char *oper_nm, int ret_flag, - struct val_loc *arg1rslt, int nargs, - struct val_loc *rslt, int optim); -static struct code *mk_cpyval (struct val_loc *loc1, struct val_loc *loc2); -static struct code *new_call (void); -static char *oper_name (struct implement *impl); -static void restr_env (struct val_loc *sub_sav, struct val_loc *pos_sav); -static void save_env (struct val_loc *sub_sav, struct val_loc *pos_sav); -static void setloc (nodeptr n); -static struct val_loc *tmp_loc (int n); -static struct val_loc *var_ref (struct lentry *sym); -static struct val_loc *vararg_sz(int n); - -#define FrstArg 2 - -/* - * Information that must be passed between a loop and its next and break - * expressions. - */ -struct loop_info { - struct code *next_lbl; /* where to branch for a next expression */ - struct code *end_loop; /* label at end of loop */ - struct code *on_failure; /* where to go if the loop fails */ - struct scan_info *scan_info; /* scanning environment upon entering loop */ - struct val_loc *rslt; /* place to put result of loop */ - struct c_fnc *succ_cont; /* the success continuation for the loop */ - struct loop_info *prev; /* link to info for outer loop */ - }; - -/* - * The allocation status of a temporary variable can either be "in use", - * "not allocated", or reserved for use at a code position (indicated - * by a specific negative number). - */ -#define InUse 1 -#define NotAlc 0 - -/* - * tmplftm is used to precompute lifetime information for use in allocating - * temporary variables. - */ -struct tmplftm { - int cur_status; - nodeptr lifetime; - }; - -/* - * Places where &subject and &pos are saved during string scanning. "outer" - * values are saved when the scanning expression is executed. "inner" - * values are saved when the scanning expression suspends. - */ -struct scan_info { - struct val_loc *outer_sub; - struct val_loc *outer_pos; - struct val_loc *inner_sub; - struct val_loc *inner_pos; - struct scan_info *next; - }; - -struct scan_info scan_base = {NULL, 0, NULL, 0, NULL}; -struct scan_info *nxt_scan = &scan_base; - -struct val_loc ignore; /* no values, just something to point at */ -static struct val_loc proc_rslt; /* result location for procedure */ - -int *tmp_status = NULL; /* allocation status of temp descriptor vars */ -int *itmp_status = NULL; /* allocation status of temp C int vars*/ -int *dtmp_status = NULL; /* allocation status of temp C double vars */ -int *sbuf_status = NULL; /* allocation of string buffers */ -int *cbuf_status = NULL; /* allocation of cset buffers */ -int num_tmp; /* number of temp descriptors actually used */ -int num_itmp; /* number of temp C ints actually used */ -int num_dtmp; /* number of temp C doubles actually used */ -int num_sbuf; /* number of string buffers actually used */ -int num_cbuf; /* number of cset buffers actually used */ -int status_sz = 20; /* current size of tmp_status array */ -int istatus_sz = 20; /* current size of itmp_status array */ -int dstatus_sz = 20; /* current size of dtmp_status array */ -int sstatus_sz = 20; /* current size of sbuf_status array */ -int cstatus_sz = 20; /* current size of cbuf_status array */ -struct freetmp *freetmp_pool = NULL; - -static char frm_prfx[PrfxSz + 1];/* prefix for procedure frame */ -static char *lastfiln; /* last file name set in code */ -static int lastline; /* last line number set in code */ - -#ifdef OptimizePoll -static struct code *lastpoll; -#endif /* OptimizePoll */ - -#ifdef OptimizeLit -static struct lit_tbl *tbl = NULL; -static struct lit_tbl *free_lit_tbl = NULL; -#endif /* OptimizeLit */ - -static struct c_fnc *fnc_lst; /* list of C functions implementing proc */ -static struct c_fnc **flst_end; /* pointer to null pointer at end of fnc_lst */ -struct c_fnc *cur_fnc; /* C function currently being built */ -static int create_lvl = 0; /* co-expression create level */ - -struct pentry *cur_proc; /* procedure currently being translated */ - -struct code *on_failure; /* place to go on failure */ - -static struct code *p_ret_lbl; /* label for procedure return */ -static struct code *p_fail_lbl; /* label for procedure fail */ -struct code *bound_sig; /* bounding signal for current procedure */ - -/* - * statically declared "signals". - */ -struct code resume; -struct code contin; -struct code fallthru; -struct code next_fail; - -int lbl_seq_num = 0; /* next label sequence number */ - -#ifdef OptimizeLit -static void print_tbl(struct lit_tbl *start) { - struct lit_tbl *ptr; - - for (ptr=start; ptr != NULL ;ptr=ptr->next) { - printf("mod (%2d) strchr (%2d) ",ptr->modified,ptr->index); - if (ptr->csym != NULL) { - printf("image (%13s) ",ptr->csym->image); - } - if (ptr->vloc != NULL) { - printf("val (%6d) type (%d)",ptr->vloc->u.tmp,ptr->vloc->loc_type); - } - if (ptr->end == NULL) - printf(" END IS NULL"); - printf("\n"); - } -} - - -static void free_tbl() { -/* - struct lit_tbl *ptr, *next; -*/ - free_lit_tbl = tbl; - tbl = NULL; -/* - ptr = tbl; - while (ptr != NULL) { - next = ptr->next; - free(ptr); - ptr = next; - } - tbl = NULL; -*/ -} - - -static struct lit_tbl *alc_tbl() { - struct lit_tbl *new; - static int cnt=0; - - - if (free_lit_tbl != NULL) { - new = free_lit_tbl; - free_lit_tbl = new->next; - } - else - new = (struct lit_tbl *)alloc(sizeof(struct lit_tbl)); - new->modified = NO_LIMIT; - new->index = -1; - new->safe = 1; - new->initial = NULL; - new->end = NULL; - new->vloc = NULL; - new->csym = NULL; - new->prev = NULL; - new->next = NULL; - return new; -} -#endif /* OptimizeLit */ - -/* - * proccode - generate code for a procedure. - */ -void proccode(proc) -struct pentry *proc; - { - struct c_fnc *fnc; - struct code *cd; - struct code *cd1; - struct code *lbl; - nodeptr n; - nodeptr failer; - int gen; - int i; -#ifdef OptimizeLit - struct code *procstart; -#endif /* OptimizeLit */ - - /* - * Initialize arrays used for allocating temporary variables. - */ - if (tmp_status == NULL) - tmp_status = (int *)alloc((unsigned int)(status_sz * sizeof(int))); - if (itmp_status == NULL) - itmp_status = (int *)alloc((unsigned int)(istatus_sz * sizeof(int))); - if (dtmp_status == NULL) - dtmp_status = (int *)alloc((unsigned int)(dstatus_sz * sizeof(int))); - if (sbuf_status == NULL) - sbuf_status = (int *)alloc((unsigned int)(sstatus_sz * sizeof(int))); - if (cbuf_status == NULL) - cbuf_status = (int *)alloc((unsigned int)(cstatus_sz * sizeof(int))); - for (i = 0; i < status_sz; ++i) - tmp_status[i] = NotAlloc; - for (i = 0; i < istatus_sz; ++i) - itmp_status[i] = NotAlloc; - for (i = 0; i < dstatus_sz; ++i) - dtmp_status[i] = NotAlloc; - for (i = 0; i < sstatus_sz; ++i) - sbuf_status[i] = NotAlloc; - for (i = 0; i < cstatus_sz; ++i) - cbuf_status[i] = NotAlloc; - num_tmp = 0; - num_itmp = 0; - num_dtmp = 0; - num_sbuf = 0; - num_cbuf = 0; - - /* - * Initialize standard signals. - */ - resume.cd_id = C_Resume; - contin.cd_id = C_Continue; - fallthru.cd_id = C_FallThru; - - /* - * Initialize procedure result and the transcan locations. - */ - proc_rslt.loc_type = V_PRslt; - proc_rslt.mod_access = M_None; - ignore.loc_type = V_Ignore; - ignore.mod_access = M_None; - - cur_proc = proc; /* current procedure */ - lastfiln = NULL; /* file name */ - lastline = 0; /* line number */ - -#ifdef OptimizePoll - lastpoll = NULL; -#endif /* OptimizePoll */ - - /* - * Procedure frame prefix is the procedure prefix. - */ - for (i = 0; i < PrfxSz; ++i) - frm_prfx[i] = cur_proc->prefix[i]; - frm_prfx[PrfxSz] = '\0'; - - /* - * Initialize the continuation list and allocate the outer function for - * this procedure. - */ - fnc_lst = NULL; - flst_end = &fnc_lst; - cur_fnc = alc_fnc(); - -#ifdef OptimizeLit - procstart = cur_fnc->cursor; -#endif /* OptimizeLit */ - - /* - * If the procedure is not used anywhere don't generate code for it. - * This can happen when using libraries containing several procedures, - * but not all are needed. However, if there is a block for the - * procedure, we need at least a dummy function. - */ - if (!cur_proc->reachable) { - if (!(glookup(cur_proc->name)->flag & F_SmplInv)) - outerfnc(fnc_lst); - return; - } - - /* - * Allocate labels for the code for procedure failure, procedure return, - * and allocate the bounding signal for this procedure (at this point - * signals and labels are not distinguished). - */ - p_fail_lbl = alc_lbl("proc fail", 0); - p_ret_lbl = alc_lbl("proc return", 0); - bound_sig = alc_lbl("bound", 0); - - n = proc->tree; - setloc(n); - if (Type(Tree1(n)) != N_Empty) { - /* - * initial clause. - */ - Tree1(n)->lifetime = NULL; - liveness(Tree1(n), NULL, &failer, &gen); - if (tfatals > 0) - return; - lbl = alc_lbl("end initial", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "!first_time"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "first_time = 0;"; - cd_add(cd); - bound(Tree1(n), &ignore, 1); - cur_fnc->cursor = lbl; - } - Tree2(n)->lifetime = NULL; - liveness(Tree2(n), NULL, &failer, &gen); - if (tfatals > 0) - return; - bound(Tree2(n), &ignore, 1); - - /* - * Place code to perform procedure failure and return and the - * end of the outer function. - */ - setloc(Tree3(n)); - cd_add(p_fail_lbl); - cd = NewCode(0); - cd->cd_id = C_PFail; - cd_add(cd); - cd_add(p_ret_lbl); - cd = NewCode(0); - cd->cd_id = C_PRet; - cd_add(cd); - - /* - * Fix up signal handling code and perform peephole optimizations. - */ - fix_fncs(fnc_lst); - -#ifdef OptimizeLit - analyze_literals(procstart, NULL, 0); - propagate_literals(); -#endif /* OptimizeLit */ - - /* - * The outer function is the first one on the list. It has the - * procedure interface; the others are just continuations. - */ - outerfnc(fnc_lst); - for (fnc = fnc_lst->next; fnc != NULL; fnc = fnc->next) - if (fnc->ref_cnt > 0) - prt_fnc(fnc); -#ifdef OptimizeLit - free_tbl(); -#endif /* OptimizeLit */ -} - -/* - * gencode - generate code for a syntax tree. - */ -static struct val_loc *gencode(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct code *cd; - struct code *cd1; - struct code *fail_sav; - struct code *lbl1; - struct code *lbl2; - struct code *cursor_sav; - struct c_fnc *fnc_sav; - struct c_fnc *fnc; - struct implement *impl; - struct implement *impl1; - struct val_loc *r1[3]; - struct val_loc *r2[2]; - struct val_loc *frst_arg; - struct lentry *single; - struct freetmp *freetmp; - struct freetmp *ft; - struct tmplftm *lifetm_ary; - char *sbuf; - int i; - int tmp_indx; - int nargs; - static struct loop_info *loop_info = NULL; - struct loop_info *li_sav; - - switch (n->n_type) { - case N_Activat: - rslt = gen_act(n, rslt); - break; - - case N_Alt: - rslt = chk_alc(rslt, n->lifetime); /* insure a result location */ - - fail_sav = on_failure; - fnc_sav = cur_fnc; - - /* - * If the first alternative fails, execution must go to the - * "alt" label. - */ - lbl1 = alc_lbl("alt", 0); - on_failure = lbl1; - - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* 1st alternative goes before label */ - gencode(Tree0(n), rslt); - - /* - * Each alternative must call the same success continuation. - */ - fnc = alc_fnc(); - callc_add(fnc); - - cur_fnc = fnc_sav; /* return to the context of the label */ - cur_fnc->cursor = lbl1; /* 2nd alternative goes after label */ - on_failure = fail_sav; /* on failure, alternation fails */ - gencode(Tree1(n), rslt); - callc_add(fnc); /* call continuation */ - - /* - * Code following the alternation goes in the continuation. If - * the code fails, the continuation returns the resume signal. - */ - cur_fnc = fnc; - on_failure = &resume; - break; - - case N_Apply: - rslt = gen_apply(n, rslt); - break; - - case N_Augop: - impl = Impl0(n); /* assignment */ - impl1 = Impl1(n); /* the operation */ - if (impl == NULL || impl1 == NULL) { - rslt = &ignore; /* make sure code generation can continue */ - break; - } - - /* - * allocate an argument list for the operation. - */ - lifetm_ary = alc_lftm(2, &n->n_field[2]); - tmp_indx = alc_tmp(2, lifetm_ary); - r1[0] = tmp_loc(tmp_indx); - r1[1] = tmp_loc(tmp_indx + 1); - - gencode(Tree2(n), r1[0]); /* first argument */ - - /* - * allocate an argument list for the assignment and copy the - * value of the first argument into it. - */ - lifetm_ary[0].cur_status = InUse; - lifetm_ary[1].cur_status = n->postn; - lifetm_ary[1].lifetime = n->intrnl_lftm; - tmp_indx = alc_tmp(2, lifetm_ary); - r2[0] = tmp_loc(tmp_indx++); - cd_add(mk_cpyval(r2[0], r1[0])); - r2[1] = tmp_loc(tmp_indx); - - gencode(Tree3(n), r1[1]); /* second argument */ - - /* - * Produce code for the operation. - */ - setloc(n); - implproto(impl1); - mk_callop(oper_name(impl1), impl1->ret_flag, r1[0], 2, r2[1], 0); - - /* - * Produce code for the assignment. - */ - implproto(impl); - if (impl->ret_flag & (DoesRet | DoesSusp)) - rslt = chk_alc(rslt, n->lifetime); - mk_callop(oper_name(impl), impl->ret_flag, r2[0], 2, rslt, 0); - - free((char *)lifetm_ary); - break; - - case N_Bar: { - struct val_loc *fail_flg; - - /* - * Allocate an integer variable to keep track of whether the - * repeated alternation should fail when execution reaches - * the top of its loop, and generate code to initialize the - * variable to 0. - */ - fail_flg = itmp_loc(alc_itmp(n->intrnl_lftm)); - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = fail_flg; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = 0;"; - cd_add(cd); - - /* - * Code at the top of the repeated alternation loop checks - * the failure flag. - */ - lbl1 = alc_lbl("rep alt", 0); - cd_add(lbl1); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_ValLoc; - cd1->ValLoc(0) = fail_flg; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - - /* - * If the expression fails without producing a value, the - * repeated alternation must fail. - */ - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = fail_flg; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = 1;"; - cd_add(cd); - - /* - * Generate code for the repeated expression. If it produces - * a value before before backtracking occurs, the loop is - * repeated as indicated by the value of the failure flag. - */ - on_failure = lbl1; - rslt = gencode(Tree0(n), rslt); - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = fail_flg; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = 0;"; - cd_add(cd); - } - break; - - case N_Break: - if (loop_info == NULL) { - nfatal(n, "invalid context for a break expression", NULL); - rslt = &ignore; - break; - } - - /* - * If the break is in a different string scanning context from the - * loop itself, generate code to restore the scanning environment. - */ - if (nxt_scan != loop_info->scan_info) - restr_env(loop_info->scan_info->outer_sub, - loop_info->scan_info->outer_pos); - - - if (Tree0(n)->n_type == N_Empty && loop_info->rslt == &ignore) { - /* - * The break has no associated expression and the loop needs - * no value, so just branch out of the loop. - */ - cd_add(sig_cd(loop_info->end_loop, cur_fnc)); - } - else { - /* - * The code for the expression associated with the break is - * actually placed at the end of the loop. Go there and - * add a label to branch to. - */ - cursor_sav = cur_fnc->cursor; - fnc_sav = cur_fnc; - fail_sav = on_failure; - cur_fnc = loop_info->end_loop->Container; - cur_fnc->cursor = loop_info->end_loop->prev; - on_failure = loop_info->on_failure; - lbl1 = alc_lbl("break", 0); - cd_add(lbl1); - - /* - * Make sure a result location has been allocated for the - * loop, restore the loop information for the next outer - * loop, generate code for the break expression, then - * restore the loop information for this loop. - */ - loop_info->rslt = chk_alc(loop_info->rslt, Tree0(n)->lifetime); - li_sav = loop_info; - loop_info = loop_info->prev; - gencode(Tree0(n), li_sav->rslt); - loop_info = li_sav; - - /* - * If this or another break expression suspends so we cannot - * just branch to the end of the loop, all breaks must - * call a common continuation. - */ - if (cur_fnc->cursor->next != loop_info->end_loop && - loop_info->succ_cont == NULL) - loop_info->succ_cont = alc_fnc(); - if (loop_info->succ_cont == NULL) - cd_add(mk_goto(loop_info->end_loop)); /* go to end of loop */ - else - callc_add(loop_info->succ_cont); /* call continuation */ - - /* - * Return to the location of the break and generate a branch to - * the code for its associated expression. - */ - cur_fnc = fnc_sav; - cur_fnc->cursor = cursor_sav; - on_failure = fail_sav; - cd_add(sig_cd(lbl1, cur_fnc)); - } - rslt = &ignore; /* shouldn't be used but must be something valid */ - break; - - case N_Case: - rslt = gen_case(n, rslt); - break; - - case N_Create: - rslt = gen_creat(n, rslt); - break; - - case N_Cset: - case N_Int: - case N_Real: - case N_Str: - cd = NewCode(2); - cd->cd_id = C_Lit; - rslt = chk_alc(rslt, n->lifetime); - cd->Rslt = rslt; - cd->Literal = CSym0(n); - cd_add(cd); - break; - - case N_Empty: - /* - * Assume null value is needed. - */ - if (rslt == &ignore) - break; - rslt = chk_alc(rslt, n->lifetime); - cd_add(asgn_null(rslt)); - break; - - case N_Field: - rslt = field_ref(n, rslt); - break; - - case N_Id: - /* - * If the variable reference is not going to be used, don't bother - * building it. - */ - if (rslt == &ignore) - break; - cd = NewCode(2); - cd->cd_id = C_NamedVar; - rslt = chk_alc(rslt, n->lifetime); - cd->Rslt = rslt; - cd->NamedVar = LSym0(n); - cd_add(cd); - break; - - case N_If: - if (Type(Tree2(n)) == N_Empty) { - /* - * if-then. Control clause is bounded, but otherwise trivial. - */ - bound(Tree0(n), &ignore, 0); /* control clause */ - rslt = gencode(Tree1(n), rslt); /* then clause */ - } - else { - /* - * if-then-else. Establish an "else" label as the failure - * label of the bounded control clause. - */ - fail_sav = on_failure; - fnc_sav = cur_fnc; - lbl1 = alc_lbl("else", 0); - on_failure = lbl1; - - bound(Tree0(n), &ignore, 0); /* control clause */ - - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* then clause goes before else lbl */ - on_failure = fail_sav; - rslt = chk_alc(rslt, n->lifetime); - gencode(Tree1(n), rslt); /* then clause */ - - /* - * If the then clause is not a generator, execution can - * just go to the end of the if-then-else expression. If it - * is a generator, the continuation for the expression must be - * in a separate function. - */ - if (cur_fnc->cursor->next == lbl1) { - fnc = NULL; - lbl2 = alc_lbl("end if", 0); - cd_add(mk_goto(lbl2)); - cur_fnc->cursor = lbl1; - cd_add(lbl2); - } - else { - lbl2 = NULL; - fnc = alc_fnc(); - callc_add(fnc); - cur_fnc = fnc_sav; - } - - cur_fnc->cursor = lbl1; /* else clause goes after label */ - on_failure = fail_sav; - gencode(Tree2(n), rslt); /* else clause */ - - /* - * If the else clause is not a generator, execution is at - * the end of the if-then-else expression, but the if clause - * may have forced the continuation to be in a separate function. - * If the else clause is a generator, it forces the continuation - * to be in a separate function. - */ - if (fnc == NULL) { - if (cur_fnc->cursor->next == lbl2) - cur_fnc->cursor = lbl2; - else { - fnc = alc_fnc(); - callc_add(fnc); - /* - * The then clause is not a generator, so it has branched - * to lbl2. We must add a call to the continuation there. - */ - cur_fnc = fnc_sav; - cur_fnc->cursor = lbl2; - on_failure = fail_sav; - callc_add(fnc); - } - } - else - callc_add(fnc); - - if (fnc != NULL) { - /* - * We produced a continuation for the if-then-else, so code - * generation must proceed in it. - */ - cur_fnc = fnc; - on_failure = &resume; - } - } - break; - - case N_Invok: - /* - * General invocation. - */ - nargs = Val0(n); - if (Tree1(n)->n_type == N_Empty) { - /* - * Mutual evaluation. - */ - for (i = 2; i <= nargs; ++i) - gencode(n->n_field[i].n_ptr, &ignore); /* arg i - 1 */ - rslt = chk_alc(rslt, n->lifetime); - gencode(n->n_field[nargs + 1].n_ptr, rslt); /* last argument */ - } - else { - ++nargs; /* consider the procedure an argument to invoke() */ - frst_arg = gen_args(n, 1, nargs); - setloc(n); - /* - * Assume this operation uses its result location as a work - * area. Give it a location that is tended, where the value - * is retained as long as the operation can be resumed. - */ - if (rslt == &ignore) - rslt = NULL; /* force allocation of temporary */ - rslt = chk_alc(rslt, max_lftm(n->lifetime, n->intrnl_lftm)); - mk_callop( "invoke", DoesRet | DoesFail | DoesSusp, frst_arg, nargs, - rslt, 0); - } - break; - - case N_InvOp: - rslt = inv_op(n, rslt); - break; - - case N_InvProc: - rslt = inv_prc(n, rslt); - break; - - case N_InvRec: { - /* - * Directly invoke a record constructor. - */ - struct rentry *rec; - - nargs = Val0(n); /* number of arguments */ - frst_arg = gen_args(n, 2, nargs); - setloc(n); - rec = Rec1(n); - - rslt = chk_alc(rslt, n->lifetime); - - /* - * If error conversion can occur then the record constructor may - * fail and we must check the signal. - */ - if (err_conv) { - sbuf = (char *)alloc((unsigned int)(strlen(rec->name) + - strlen("signal = R_") + PrfxSz + 1)); - sprintf(sbuf, "signal = R%s_%s(", rec->prefix, rec->name); - } - else { - sbuf = (char *)alloc((unsigned int)(strlen(rec->name) + PrfxSz +4)); - sprintf(sbuf, "R%s_%s(", rec->prefix, rec->name); - } - cd = alc_ary(9); - cd->ElemTyp(0) = A_Str; /* constructor name */ - cd->Str(0) = sbuf; - cd->ElemTyp(1) = A_Intgr; /* number of arguments */ - cd->Intgr(1) = nargs; - cd->ElemTyp(2) = A_Str; /* , */ - cd->Str(2) = ", "; - if (frst_arg == NULL) { /* location of first argument */ - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "NULL"; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ""; - } - else { - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "&"; - cd->ElemTyp(4) = A_ValLoc; - cd->ValLoc(4) = frst_arg; - } - cd->ElemTyp(5) = A_Str; /* , */ - cd->Str(5) = ", "; - cd->ElemTyp(6) = A_Str; /* location of result */ - cd->Str(6) = "&"; - cd->ElemTyp(7) = A_ValLoc; - cd->ValLoc(7) = rslt; - cd->ElemTyp(8) = A_Str; - cd->Str(8) = ");"; - cd_add(cd); - if (err_conv) { - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "signal == A_Resume"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - } - } - break; - - case N_Limit: - rslt = gen_lim(n, rslt); - break; - - case N_Loop: { - struct loop_info li; - - /* - * Set up loop information for use by break and next expressions. - */ - li.end_loop = alc_lbl("end loop", 0); - cd_add(li.end_loop); - cur_fnc->cursor = li.end_loop->prev; /* loop goes before label */ - li.rslt = rslt; - li.on_failure = on_failure; - li.scan_info = nxt_scan; - li.succ_cont = NULL; - li.prev = loop_info; - loop_info = &li; - - switch ((int)Val0(Tree0(n))) { - case EVERY: - /* - * "next" in the control clause just fails. - */ - li.next_lbl = &next_fail; - gencode(Tree1(n), &ignore); /* control clause */ - /* - * "next" in the do clause transfers control to the - * statement at the end of the loop that resumes the - * control clause. - */ - li.next_lbl = alc_lbl("next", 0); - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(li.next_lbl); - cd_add(sig_cd(on_failure, cur_fnc)); /* resume control clause */ - break; - - case REPEAT: - li.next_lbl = alc_lbl("repeat", 0); - cd_add(li.next_lbl); - bound(Tree1(n), &ignore, 1); - cd_add(mk_goto(li.next_lbl)); - break; - - case SUSPEND: /* suspension expression */ - if (create_lvl > 0) { - nfatal(n, "invalid context for suspend", NULL); - return &ignore; - } - /* - * "next" in the control clause just fails. The result - * of the control clause goes in the procedure return - * location. - */ - li.next_lbl = &next_fail; - genretval(n, Tree1(n), &proc_rslt); - - /* - * If necessary, swap scanning environments before suspending. - * if there is no success continuation, just return. - */ - if (nxt_scan != &scan_base) { - save_env(scan_base.inner_sub, scan_base.inner_pos); - restr_env(scan_base.outer_sub, scan_base.outer_pos); - } - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(2); - cd1->ElemTyp(0) = A_ProcCont; - cd1->ElemTyp(1) = A_Str; - cd1->Str(1) = " == NULL"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(p_ret_lbl, cur_fnc); - cd_add(cd); - cd = NewCode(0); - cd->cd_id = C_PSusp; - cd_add(cd); - cur_fnc->flag |= CF_ForeignSig; - - /* - * Force updating file name and line number, and if needed, - * switch scanning environments before resuming. - */ - lastfiln = NULL; - lastline = 0; - if (nxt_scan != &scan_base) { - save_env(scan_base.outer_sub, scan_base.outer_pos); - restr_env(scan_base.inner_sub, scan_base.inner_pos); - } - - /* - * "next" in the do clause transfers control to the - * statement at the end of the loop that resumes the - * control clause. - */ - li.next_lbl = alc_lbl("next", 0); - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(li.next_lbl); - cd_add(sig_cd(on_failure, cur_fnc)); - break; - - case WHILE: - li.next_lbl = alc_lbl("while", 0); - cd_add(li.next_lbl); - /* - * The control clause and do clause are both bounded expressions, - * but only the do clause establishes a new failure label. - */ - bound(Tree1(n), &ignore, 0); /* control clause */ - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(mk_goto(li.next_lbl)); - break; - - case UNTIL: - fail_sav = on_failure; - li.next_lbl = alc_lbl("until", 0); - cd_add(li.next_lbl); - - /* - * If the control clause fails, execution continues in - * the loop. - */ - if (Type(Tree2(n)) == N_Empty) - on_failure = li.next_lbl; - else { - lbl2 = alc_lbl("do", 0); - on_failure = lbl2; - cd_add(lbl2); - cur_fnc->cursor = lbl2->prev; /* control before label */ - } - bound(Tree1(n), &ignore, 0); /* control clause */ - - /* - * If the control clause succeeds, the loop fails. - */ - cd_add(sig_cd(fail_sav, cur_fnc)); - - if (Type(Tree2(n)) != N_Empty) { - /* - * Do clause goes after the label and the loop repeats. - */ - cur_fnc->cursor = lbl2; - bound(Tree2(n), &ignore, 1); /* do clause */ - cd_add(mk_goto(li.next_lbl)); - } - break; - } - - /* - * Go to the end of the loop and see if the loop's success continuation - * is in a separate function. - */ - cur_fnc = li.end_loop->Container; - cur_fnc->cursor = li.end_loop; - if (li.succ_cont != NULL) { - callc_add(li.succ_cont); - cur_fnc = li.succ_cont; - on_failure = &resume; - } - if (li.rslt == NULL) - rslt = &ignore; /* shouldn't be used but must be something valid */ - else - rslt = li.rslt; - loop_info = li.prev; - break; - } - - case N_Next: - /* - * In some contexts "next" just fails. In other contexts it - * transfers control to a label, in which case it may have - * to restore a scanning environment. - */ - if (loop_info == NULL) - nfatal(n, "invalid context for a next expression", NULL); - else if (loop_info->next_lbl == &next_fail) - cd_add(sig_cd(on_failure, cur_fnc)); - else { - if (nxt_scan != loop_info->scan_info) - restr_env(loop_info->scan_info->outer_sub, - loop_info->scan_info->outer_pos); - cd_add(sig_cd(loop_info->next_lbl, cur_fnc)); - } - rslt = &ignore; /* shouldn't be used but must be something valid */ - break; - - case N_Not: - lbl1 = alc_lbl("not", 0); - fail_sav = on_failure; - on_failure = lbl1; - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* code goes before label */ - bound(Tree0(n), &ignore, 0); - on_failure = fail_sav; - cd_add(sig_cd(on_failure, cur_fnc)); /* convert success to failure */ - cur_fnc->cursor = lbl1; /* convert failure to null */ - if (rslt != &ignore) { - rslt = chk_alc(rslt, n->lifetime); - cd_add(asgn_null(rslt)); - } - break; - - case N_Ret: - if (create_lvl > 0) { - nfatal(n, "invalid context for return or fail", NULL); - return &ignore; - } - if (Val0(Tree0(n)) == RETURN) { - /* - * Set up the failure action of the return expression to do a - * procedure fail. - */ - if (nxt_scan != &scan_base) { - /* - * we must switch scanning environments if the expression fails. - */ - lbl1 = alc_lbl("return fail", 0); - cd_add(lbl1); - restr_env(scan_base.outer_sub, scan_base.outer_pos); - cd_add(sig_cd(p_fail_lbl, cur_fnc)); - cur_fnc->cursor = lbl1->prev; /* code goes before label */ - on_failure = lbl1; - } - else - on_failure = p_fail_lbl; - - /* - * Produce code to place return value in procedure result location. - */ - genretval(n, Tree1(n), &proc_rslt); - - /* - * See if a scanning environment must be restored and - * transfer control to the procedure return code. - */ - if (nxt_scan != &scan_base) - restr_env(scan_base.outer_sub, scan_base.outer_pos); - cd_add(sig_cd(p_ret_lbl, cur_fnc)); - } - else { - /* - * fail. See if a scanning environment must be restored and - * transfer control to the procedure failure code. - */ - if (nxt_scan != &scan_base) - restr_env(scan_base.outer_sub, scan_base.outer_pos); - cd_add(sig_cd(p_fail_lbl, cur_fnc)); - } - rslt = &ignore; /* shouldn't be used but must be something valid */ - break; - - case N_Scan: - rslt = gen_scan(n, rslt); - break; - - case N_Sect: - /* - * x[i+:j] or x[i-:j] (x[i:j] handled as ordinary operator) - */ - impl1 = Impl0(n); /* sectioning */ - if (impl1 == NULL) { - rslt = &ignore; /* make sure code generation can continue */ - break; - } - implproto(impl1); - - impl = Impl1(n); /* plus or minus */ - /* - * Allocate work area of temporary variables for sectioning. - */ - lifetm_ary = alc_lftm(3, NULL); - lifetm_ary[0].cur_status = Tree2(n)->postn; - lifetm_ary[0].lifetime = n->intrnl_lftm; - lifetm_ary[1].cur_status = Tree3(n)->postn; - lifetm_ary[1].lifetime = n->intrnl_lftm; - lifetm_ary[2].cur_status = n->postn; - lifetm_ary[2].lifetime = n->intrnl_lftm; - tmp_indx = alc_tmp(3, lifetm_ary); - for (i = 0; i < 3; ++i) - r1[i] = tmp_loc(tmp_indx++); - gencode(Tree2(n), r1[0]); /* generate code to compute x */ - gencode(Tree3(n), r1[1]); /* generate code compute i */ - - /* - * Allocate work area of temporary variables for arithmetic. - */ - lifetm_ary[0].cur_status = InUse; - lifetm_ary[0].lifetime = Tree3(n)->lifetime; - lifetm_ary[1].cur_status = Tree4(n)->postn; - lifetm_ary[1].lifetime = Tree4(n)->lifetime; - tmp_indx = alc_tmp(2, lifetm_ary); - for (i = 0; i < 2; ++i) - r2[i] = tmp_loc(tmp_indx++); - cd_add(mk_cpyval(r2[0], r1[1])); /* generate code to copy i */ - gencode(Tree4(n), r2[1]); /* generate code to compute j */ - - /* - * generate code for i op j. - */ - setloc(n); - implproto(impl); - mk_callop(oper_name(impl), impl->ret_flag, r2[0], 2, r1[2], 0); - - /* - * generate code for x[i : (i op j)] - */ - rslt = chk_alc(rslt, n->lifetime); - mk_callop(oper_name(impl1),impl1->ret_flag,r1[0],3,rslt,0); - free((char *)lifetm_ary); - break; - - case N_Slist: - bound(Tree0(n), &ignore, 1); - rslt = gencode(Tree1(n), rslt); - break; - - case N_SmplAsgn: { - struct val_loc *var, *val; - - /* - * Optimized assignment to a named variable. Use information - * from type inferencing to determine if the right-hand-side - * is a variable. - */ - var = var_ref(LSym0(Tree2(n))); - if (HasVar(varsubtyp(Tree3(n)->type, &single))) - Val0(n) = AsgnDeref; - if (single != NULL) { - /* - * Right-hand-side results in a named variable. Compute - * the expression but don't bother saving the result, we - * know what it is. Assignment just copies value from - * one variable to the other. - */ - gencode(Tree3(n), &ignore); - val = var_ref(single); - cd_add(mk_cpyval(var, val)); - } - else switch (Val0(n)) { - case AsgnDirect: - /* - * It is safe to compute the result directly into the variable. - */ - gencode(Tree3(n), var); - break; - case AsgnCopy: - /* - * The result is not a variable reference, but it is not - * safe to compute it into the variable, we must use a - * temporary variable. - */ - val = gencode(Tree3(n), NULL); - cd_add(mk_cpyval(var, val)); - break; - case AsgnDeref: - /* - * We must dereference the result into the variable. - */ - val = gencode(Tree3(n), NULL); - deref_cd(val, var); - break; - } - - /* - * If the assignment has to produce a result, construct the - * variable reference. - */ - if (rslt != &ignore) - rslt = gencode(Tree2(n), rslt); - } - break; - - case N_SmplAug: { - /* - * Optimized augmented assignment to a named variable. - */ - struct val_loc *var, *val; - - impl = Impl1(n); /* the operation */ - if (impl == NULL) { - rslt = &ignore; /* make sure code generation can continue */ - break; - } - - implproto(impl); /* insure prototype for operation */ - - /* - * Generate code to compute the arguments for the operation. - */ - frst_arg = gen_args(n, 2, 2); - setloc(n); - - /* - * Use information from type inferencing to determine if the - * operation produces a variable. - */ - if (HasVar(varsubtyp(Typ4(n), &single))) - Val0(n) = AsgnDeref; - var = var_ref(LSym0(Tree2(n))); - if (single != NULL) { - /* - * The operation results in a named variable. Call the operation - * but don't bother saving the result, we know what it is. - * Assignment just copies value from one variable to the other. - */ - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, - &ignore, 0); - val = var_ref(single); - cd_add(mk_cpyval(var, val)); - } - else switch (Val0(n)) { - case AsgnDirect: - /* - * It is safe to compute the result directly into the variable. - */ - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, - var, 0); - break; - case AsgnCopy: - /* - * The result is not a variable reference, but it is not - * safe to compute it into the variable, we must use a - * temporary variable. - */ - val = chk_alc(NULL, n); - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, val, 0); - cd_add(mk_cpyval(var, val)); - break; - case AsgnDeref: - /* - * We must dereference the result into the variable. - */ - val = chk_alc(NULL, n); - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, val, 0); - deref_cd(val, var); - break; - } - - /* - * If the assignment has to produce a result, construct the - * variable reference. - */ - if (rslt != &ignore) - rslt = gencode(Tree2(n), rslt); - } - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - - /* - * Free any temporaries whose lifetime ends at this node. - */ - freetmp = n->freetmp; - while (freetmp != NULL) { - switch (freetmp->kind) { - case DescTmp: - tmp_status[freetmp->indx] = freetmp->old; - break; - case CIntTmp: - itmp_status[freetmp->indx] = freetmp->old; - break; - case CDblTmp: - dtmp_status[freetmp->indx] = freetmp->old; - break; - case SBuf: - sbuf_status[freetmp->indx] = freetmp->old; - break; - case CBuf: - cbuf_status[freetmp->indx] = freetmp->old; - break; - } - ft = freetmp->next; - freetmp->next = freetmp_pool; - freetmp_pool = freetmp; - freetmp = ft; - } - return rslt; - } - -/* - * chk_alc - make sure a result location has been allocated. If it is - * a temporary variable, indicate that it is now in use. - */ -struct val_loc *chk_alc(rslt, lifetime) -struct val_loc *rslt; -nodeptr lifetime; - { - struct tmplftm tmplftm; - - if (rslt == NULL) { - if (lifetime == NULL) - rslt = &ignore; - else { - tmplftm.cur_status = InUse; - tmplftm.lifetime = lifetime; - rslt = tmp_loc(alc_tmp(1, &tmplftm)); - } - } - else if (rslt->loc_type == V_Temp) - tmp_status[rslt->u.tmp] = InUse; - return rslt; - } - -/* - * mk_goto - make a code structure for goto label - */ -struct code *mk_goto(label) -struct code *label; - { - register struct code *cd; - - cd = NewCode(1); /* # fields == # fields of C_RetSig & C_Break */ - cd->cd_id = C_Goto; - cd->next = NULL; - cd->prev = NULL; - cd->Lbl = label; - ++label->RefCnt; - return cd; - } - -/* - * mk_cpyval - make code to copy a value from one location to another. - */ -static struct code *mk_cpyval(loc1, loc2) -struct val_loc *loc1; -struct val_loc *loc2; - { - struct code *cd; - - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = loc1; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = "; - cd->ElemTyp(2) = A_ValLoc; - cd->ValLoc(2) = loc2; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ";"; - return cd; - } - -/* - * asgn_null - make code to assign the null value to a location. - */ -static struct code *asgn_null(loc1) -struct val_loc *loc1; - { - struct code *cd; - - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = loc1; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = nulldesc;"; - return cd; - } - -/* - * oper_name - create the name for the most general implementation of an Icon - * operation. - */ -static char *oper_name(impl) -struct implement *impl; - { - char *sbuf; - - sbuf = (char *)alloc((unsigned int)(strlen(impl->name) + 5)); - sprintf(sbuf, "%c%c%c_%s", impl->oper_typ, impl->prefix[0], impl->prefix[1], - impl->name); - return sbuf; - } - -/* - * gen_args - generate code to evaluate an argument list. - */ -static struct val_loc *gen_args(n, frst_arg, nargs) -struct node *n; -int frst_arg; -int nargs; - { - struct tmplftm *lifetm_ary; - int i; - int tmp_indx; - - if (nargs == 0) - return NULL; - - lifetm_ary = alc_lftm(nargs, &n->n_field[frst_arg]); - tmp_indx = alc_tmp(nargs, lifetm_ary); - for (i = 0; i < nargs; ++i) - gencode(n->n_field[frst_arg + i].n_ptr, tmp_loc(tmp_indx + i)); - free((char *)lifetm_ary); - return tmp_loc(tmp_indx); - } - -/* - * gen_case - generate code for a case expression. - */ -static struct val_loc *gen_case(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct node *control; - struct node *cases; - struct node *deflt; - struct node *clause; - struct val_loc *r1; - struct val_loc *r2; - struct val_loc *r3; - struct code *cd; - struct code *cd1; - struct code *fail_sav; - struct code *skp_lbl; - struct code *cd_lbl; - struct code *end_lbl; - struct c_fnc *fnc_sav; - struct c_fnc *succ_cont = NULL; - - control = Tree0(n); - cases = Tree1(n); - deflt = Tree2(n); - - /* - * The control clause is bounded. - */ - r1 = chk_alc(NULL, n); - bound(control, r1, 0); - - /* - * Remember the context in which the case expression occurs and - * establish a label at the end of the expression. - */ - fail_sav = on_failure; - fnc_sav = cur_fnc; - end_lbl = alc_lbl("end case", 0); - cd_add(end_lbl); - cur_fnc->cursor = end_lbl->prev; /* generate code before the end label */ - - /* - * All cases share the result location of the case expression. - */ - rslt = chk_alc(rslt, n->lifetime); - r2 = chk_alc(NULL, n); /* for result of selection clause */ - r3 = chk_alc(NULL, n); /* for dereferenced result of control clause */ - - while (cases != NULL) { - /* - * See if we are at the end of the case clause list. - */ - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - /* - * If the evaluation of the selection code or the comparison of - * its value to the control clause fail, execution will proceed - * to the "skip clause" label and on to the next case. - */ - skp_lbl = alc_lbl("skip clause", 0); - on_failure = skp_lbl; - cd_add(skp_lbl); - cur_fnc->cursor = skp_lbl->prev; /* generate code before end label */ - - /* - * Bound the selection code for this clause. - */ - cd_lbl = alc_lbl("selected code", Bounding); - cd_add(cd_lbl); - cur_fnc->cursor = cd_lbl->prev; - gencode(Tree0(clause), r2); - - /* - * Dereference the results of the control clause and the selection - * clause and compare them. - */ - setloc(clause); - deref_cd(r1, r3); - deref_cd(r2, r2); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(5); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "!equiv(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = r3; - cd->Cond = cd1; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", &"; - cd1->ElemTyp(3) = A_ValLoc; - cd1->ValLoc(3) = r2; - cd1->ElemTyp(4) = A_Str; - cd1->Str(4) = ")"; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - cd_add(sig_cd(cd_lbl, cur_fnc)); /* transfer control to bounding label */ - - /* - * Generate code for the body of this clause after the bounding label. - */ - cur_fnc = fnc_sav; - cur_fnc->cursor = cd_lbl; - on_failure = fail_sav; - gencode(Tree1(clause), rslt); - - /* - * If this clause is a generator, call the success continuation - * for the case expression, otherwise branch to the end of the - * expression. - */ - if (cur_fnc->cursor->next != skp_lbl) { - if (succ_cont == NULL) - succ_cont = alc_fnc(); /* allocate a continuation function */ - callc_add(succ_cont); - cur_fnc = fnc_sav; - } - else - cd_add(mk_goto(end_lbl)); - - /* - * The code for the next clause goes after the "skip" label of - * this clause. - */ - cur_fnc->cursor = skp_lbl; - } - - if (deflt == NULL) - cd_add(sig_cd(fail_sav, cur_fnc)); /* default action is failure */ - else { - /* - * There is an explicit default action. - */ - on_failure = fail_sav; - gencode(deflt, rslt); - if (cur_fnc->cursor->next != end_lbl) { - if (succ_cont == NULL) - succ_cont = alc_fnc(); - callc_add(succ_cont); - cur_fnc = fnc_sav; - } - } - cur_fnc->cursor = end_lbl; - - /* - * If some clauses are generators but others have transferred control - * to here, we must call the success continuation of the case - * expression and generate subsequent code there. - */ - if (succ_cont != NULL) { - on_failure = fail_sav; - callc_add(succ_cont); - cur_fnc = succ_cont; - on_failure = &resume; - } - return rslt; - } - -/* - * gen_creat - generate code to create a co-expression. - */ -static struct val_loc *gen_creat(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct code *cd; - struct code *fail_sav; - struct code *fail_lbl; - struct c_fnc *fnc_sav; - struct c_fnc *fnc; - struct val_loc *co_rslt; - struct freetmp *ft; - char sav_prfx[PrfxSz]; - int *tmp_sv; - int *itmp_sv; - int *dtmp_sv; - int *sbuf_sv; - int *cbuf_sv; - int ntmp_sv; - int nitmp_sv; - int ndtmp_sv; - int nsbuf_sv; - int ncbuf_sv; - int stat_sz_sv; - int istat_sz_sv; - int dstat_sz_sv; - int sstat_sz_sv; - int cstat_sz_sv; - int i; - - - rslt = chk_alc(rslt, n->lifetime); - - fail_sav = on_failure; - fnc_sav = cur_fnc; - for (i = 0; i < PrfxSz; ++i) - sav_prfx[i] = frm_prfx[i]; - - /* - * Temporary variables are allocated independently for the co-expression. - */ - tmp_sv = tmp_status; - itmp_sv = itmp_status; - dtmp_sv = dtmp_status; - sbuf_sv = sbuf_status; - cbuf_sv = cbuf_status; - stat_sz_sv = status_sz; - istat_sz_sv = istatus_sz; - dstat_sz_sv = dstatus_sz; - sstat_sz_sv = sstatus_sz; - cstat_sz_sv = cstatus_sz; - ntmp_sv = num_tmp; - nitmp_sv = num_itmp; - ndtmp_sv = num_dtmp; - nsbuf_sv = num_sbuf; - ncbuf_sv = num_cbuf; - tmp_status = (int *)alloc((unsigned int)(status_sz * sizeof(int))); - itmp_status = (int *)alloc((unsigned int)(istatus_sz * sizeof(int))); - dtmp_status = (int *)alloc((unsigned int)(dstatus_sz * sizeof(int))); - sbuf_status = (int *)alloc((unsigned int)(sstatus_sz * sizeof(int))); - cbuf_status = (int *)alloc((unsigned int)(cstatus_sz * sizeof(int))); - for (i = 0; i < status_sz; ++i) - tmp_status[i] = NotAlloc; - for (i = 0; i < istatus_sz; ++i) - itmp_status[i] = NotAlloc; - for (i = 0; i < dstatus_sz; ++i) - dtmp_status[i] = NotAlloc; - for (i = 0; i < sstatus_sz; ++i) - sbuf_status[i] = NotAlloc; - for (i = 0; i < cstatus_sz; ++i) - cbuf_status[i] = NotAlloc; - num_tmp = 0; - num_itmp = 0; - num_dtmp = 0; - num_sbuf = 0; - num_cbuf = 0; - - /* - * Put code for co-expression in separate function. We will need a new - * type of procedure frame which contains copies of local variables, - * copies of arguments, and temporaries for use by the co-expression. - */ - fnc = alc_fnc(); - fnc->ref_cnt = 1; - fnc->flag |= CF_Coexpr; - ChkPrefix(fnc->prefix); - for (i = 0; i < PrfxSz; ++i) - frm_prfx[i] = fnc->frm_prfx[i] = fnc->prefix[i]; - cur_fnc = fnc; - - /* - * Set up a co-expression failure label followed by a context switch - * and a branch back to the failure label. - */ - fail_lbl = alc_lbl("co_fail", 0); - cd_add(fail_lbl); - lastline = 0; /* force setting line number so tracing matches interp */ - setloc(n); - cd = alc_ary(2); - cd->ElemTyp(0) = A_Str; - cd->ElemTyp(1) = A_Str; - cd->Str(0) = "co_chng(popact((struct b_coexpr *)BlkLoc(k_current)),"; - cd->Str(1) = "NULL, NULL, A_Cofail, 1);"; - cd_add(cd); - cd_add(mk_goto(fail_lbl)); - cur_fnc->cursor = fail_lbl->prev; /* code goes before failure label */ - on_failure = fail_lbl; - - /* - * Generate code for the co-expression body, using the same - * dereferencing rules as for procedure return. - */ - lastfiln = ""; /* force setting of file name and line number */ - lastline = 0; - setloc(n); - ++create_lvl; - co_rslt = genretval(n, Tree0(n), NULL); - --create_lvl; - - /* - * If the co-expression might produce a result, generate a co-expression - * context switch. - */ - if (co_rslt != NULL) { - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "++BlkLoc(k_current)->coexpr.size;"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "co_chng(popact((struct b_coexpr *)BlkLoc(k_current)), &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = co_rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", NULL, A_Coret, 1);"; - cd_add(cd); - cd_add(sig_cd(on_failure, cur_fnc)); /* if reactivated, resume expr */ - } - - /* - * Output the new frame definition. - */ - prt_frame(frm_prfx, cur_proc->tnd_loc + num_tmp + Abs(cur_proc->nargs), - num_itmp, num_dtmp, num_sbuf, num_cbuf); - - /* - * Now return to original function and produce code to create the - * co-expression. - */ - cur_fnc = fnc_sav; - for (i = 0; i < PrfxSz; ++i) - frm_prfx[i] = sav_prfx[i]; - on_failure = fail_sav; - - lastfiln = ""; /* force setting of file name and line number */ - lastline = 0; - setloc(n); - cd = NewCode(5); - cd->cd_id = C_Create; - cd->Rslt = rslt; - cd->Cont = fnc; - cd->NTemps = num_tmp; - cd->WrkSize = num_itmp; - cd->NextCreat = cur_fnc->creatlst; - cur_fnc->creatlst = cd; - cd_add(cd); - - /* - * Restore arrays for temporary variable allocation. - */ - free((char *)tmp_status); - free((char *)itmp_status); - free((char *)dtmp_status); - free((char *)sbuf_status); - free((char *)cbuf_status); - tmp_status = tmp_sv; - itmp_status = itmp_sv; - dtmp_status = dtmp_sv; - sbuf_status = sbuf_sv; - cbuf_status = cbuf_sv; - status_sz = stat_sz_sv; - istatus_sz = istat_sz_sv; - dstatus_sz = dstat_sz_sv; - sstatus_sz = sstat_sz_sv; - cstatus_sz = cstat_sz_sv; - num_tmp = ntmp_sv; - num_itmp = nitmp_sv; - num_dtmp = ndtmp_sv; - num_sbuf = nsbuf_sv; - num_cbuf = ncbuf_sv; - - /* - * Temporary variables that exist to the end of the co-expression - * have no meaning in the surrounding code and must not be - * deallocated there. - */ - while (n->freetmp != NULL) { - ft = n->freetmp->next; - n->freetmp->next = freetmp_pool; - freetmp_pool = n->freetmp; - n->freetmp = ft; - } - - return rslt; - } - -/* - * gen_lim - generate code for limitation. - */ -static struct val_loc *gen_lim(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct node *expr; - struct node *limit; - struct val_loc *lim_desc; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct code *fail_sav; - struct c_fnc *fnc_sav; - struct c_fnc *succ_cont; - struct val_loc *lim_int; - struct lentry *single; - int deref; - - expr = Tree0(n); - limit = Tree1(n); - - /* - * Generate code to compute the limitation value and dereference it. - */ - deref = HasVar(varsubtyp(limit->type, &single)); - if (single != NULL) { - /* - * Limitation is in a named variable. Use value directly from - * the variable rather than saving the result of the expression. - */ - gencode(limit, &ignore); - lim_desc = var_ref(single); - } - else { - lim_desc = gencode(limit, NULL); - if (deref) - deref_cd(lim_desc, lim_desc); - } - - setloc(n); - fail_sav = on_failure; - - /* - * Try to convert the limitation value into an integer. - */ - lim_int = itmp_loc(alc_itmp(n->intrnl_lftm)); - cur_symtyps = n->symtyps; - if (largeints || (eval_is(int_typ, 0) & MaybeFalse)) { - /* - * Must call the conversion routine. - */ - lbl = alc_lbl("limit is int", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* conversion goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(5); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "cnv_c_int(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = lim_desc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", &"; - cd1->ElemTyp(3) = A_ValLoc; - cd1->ValLoc(3) = lim_int; - cd1->ElemTyp(4) = A_Str; - cd1->Str(4) = ")"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(101, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = lim_desc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - else { - /* - * The C integer is in the vword. - */ - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = lim_int; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = IntVal("; - cd->ElemTyp(2) = A_ValLoc; - cd->ValLoc(2) = lim_desc; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ");"; - cd_add(cd); - } - - /* - * Make sure the limitation value is positive. - */ - lbl = alc_lbl("limit positive", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(2); - cd1->ElemTyp(0) = A_ValLoc; - cd1->ValLoc(0) = lim_int; - cd1->ElemTyp(1) = A_Str; - cd1->Str(1) = " >= 0"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(205, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = lim_desc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - - /* - * If the limitation value is 0, fail immediately. - */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(2); - cd1->ElemTyp(0) = A_ValLoc; - cd1->ValLoc(0) = lim_int; - cd1->ElemTyp(1) = A_Str; - cd1->Str(1) = " == 0"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - - /* - * Establish where to go when limit has been reached. - */ - fnc_sav = cur_fnc; - lbl = alc_lbl("limit", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* limited expression goes before label */ - - /* - * Generate code for limited expression and to check the limit value. - */ - rslt = gencode(expr, rslt); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "--"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = lim_int; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = " == 0"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(lbl, cur_fnc); - cd_add(cd); - - /* - * Call the success continuation both here and after the limitation - * label. - */ - succ_cont = alc_fnc(); - callc_add(succ_cont); - cur_fnc = fnc_sav; - cur_fnc->cursor = lbl; - on_failure = fail_sav; - callc_add(succ_cont); - cur_fnc = succ_cont; - on_failure = &resume; - - return rslt; - } - -/* - * gen_apply - generate code for the apply operator, !. - */ -static struct val_loc *gen_apply(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct val_loc *callee; - struct val_loc *lst; - struct code *arg_lst; - struct code *on_ret; - struct c_fnc *fnc; - - /* - * Generate code to compute the two operands. - */ - callee = gencode(Tree0(n), NULL); - lst = gencode(Tree1(n), NULL); - rslt = chk_alc(rslt, n->lifetime); - setloc(n); - - /* - * Construct argument list for apply(). - */ - arg_lst = alc_ary(6); - arg_lst->ElemTyp(0) = A_Str; - arg_lst->Str(0) = "&"; - arg_lst->ElemTyp(1) = A_ValLoc; - arg_lst->ValLoc(1) = callee; - arg_lst->ElemTyp(2) = A_Str; - arg_lst->Str(2) = ", &"; - arg_lst->ElemTyp(3) = A_ValLoc; - arg_lst->ValLoc(3) = lst; - arg_lst->ElemTyp(4) = A_Str; - arg_lst->Str(4) = ", &"; - arg_lst->ElemTyp(5) = A_ValLoc; - arg_lst->ValLoc(5) = rslt; - - /* - * Generate code to call apply(). Assume the operation can suspend and - * allocate a continuation. If it returns a "continue" signal, - * just break out of the signal handling code and fall into a call - * to the continuation. - */ - on_ret = NewCode(1); /* #fields for C_Break == #fields for C_Goto */ - on_ret->cd_id = C_Break; - on_ret->next = NULL; - on_ret->prev = NULL; - fnc = alc_fnc(); /* success continuation */ - callo_add("apply", DoesFail | DoesRet | DoesSusp, fnc, 1, arg_lst, on_ret); - callc_add(fnc); - cur_fnc = fnc; /* subsequent code goes in the continuation */ - on_failure = &resume; - - return rslt; - } - - -/* - * gen_scan - generate code for string scanning. - */ -static struct val_loc *gen_scan(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct node *op; - struct node *subj; - struct node *body; - struct scan_info *scanp; - struct val_loc *asgn_var; - struct val_loc *new_subj; - struct val_loc *scan_rslt; - struct tmplftm *lifetm_ary; - struct lentry *subj_single; - struct lentry *body_single; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct implement *impl; - int subj_deref; - int body_deref; - int op_tok; - int tmp_indx; - - op = Tree0(n); /* operator node '?' or '?:=' */ - subj = Tree1(n); /* subject expression */ - body = Tree2(n); /* scanning expression */ - op_tok = optab[Val0(op)].tok.t_type; - - /* - * The location of the save areas for scanning environments is stored - * in list so they can be accessed by expressions that transfer - * control out of string scanning. Get the next list element and - * allocate the save areas in the procedure frame. - */ - scanp = nxt_scan; - if (nxt_scan->next == NULL) - nxt_scan->next = NewStruct(scan_info); - nxt_scan = nxt_scan->next; - scanp->outer_sub = chk_alc(NULL, n->intrnl_lftm); - scanp->outer_pos = itmp_loc(alc_itmp(n->intrnl_lftm)); - scanp->inner_sub = chk_alc(NULL, n->intrnl_lftm); - scanp->inner_pos = itmp_loc(alc_itmp(n->intrnl_lftm)); - - subj_deref = HasVar(varsubtyp(subj->type, &subj_single)); - if (subj_single != NULL) { - /* - * The subject value is in a named variable. Use value directly from - * the variable rather than saving the result of the expression. - */ - gencode(subj, &ignore); - new_subj = var_ref(subj_single); - - if (op_tok == AUGQMARK) { - body_deref = HasVar(varsubtyp(body->type, &body_single)); - if (body_single != NULL) - scan_rslt = &ignore; /* we know where the value will be */ - else - scan_rslt = chk_alc(NULL, n->intrnl_lftm); - } - else - scan_rslt = rslt; /* result of 2nd operand is result of scanning */ - } - else if (op_tok == AUGQMARK) { - /* - * Augmented string scanning using general assignment. The operands - * must be in consecutive locations. - */ - lifetm_ary = alc_lftm(2, &n->n_field[1]); - tmp_indx = alc_tmp(2, lifetm_ary); - asgn_var = tmp_loc(tmp_indx++); - scan_rslt = tmp_loc(tmp_indx); - free((char *)lifetm_ary); - - gencode(subj, asgn_var); - new_subj = chk_alc(NULL, n->intrnl_lftm); - deref_cd(asgn_var, new_subj); - } - else { - new_subj = gencode(subj, NULL); - if (subj_deref) - deref_cd(new_subj, new_subj); - scan_rslt = rslt; /* result of 2nd operand is result of scanning */ - } - - /* - * Produce code to save the old scanning environment. - */ - setloc(op); - save_env(scanp->outer_sub, scanp->outer_pos); - - /* - * Produce code to handle failure of the body of string scanning. - */ - lbl = alc_lbl("scan fail", 0); - cd_add(lbl); - restr_env(scanp->outer_sub, scanp->outer_pos); - cd_add(sig_cd(on_failure, cur_fnc)); /* fail */ - cur_fnc->cursor = lbl->prev; /* body goes before label */ - on_failure = lbl; - - /* - * If necessary, try to convert the subject to a string. Note that if - * error conversion occurs, backtracking will restore old subject. - */ - cur_symtyps = n->symtyps; - if (eval_is(str_typ, 0) & MaybeFalse) { - lbl = alc_lbl("&subject is string", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "cnv_str(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = new_subj; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", &k_subject)"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(103, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = new_subj; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - else { - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_subject = "; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = new_subj; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ";"; - cd_add(cd); - } - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_pos = 1;"; - cd_add(cd); - - scan_rslt = gencode(body, scan_rslt); - - setloc(op); - if (op_tok == AUGQMARK) { - /* - * '?:=' - perform assignment. - */ - if (subj_single != NULL) { - /* - * Assignment to a named variable. - */ - if (body_single != NULL) - cd_add(mk_cpyval(new_subj, var_ref(body_single))); - else if (body_deref) - deref_cd(scan_rslt, new_subj); - else - cd_add(mk_cpyval(new_subj, scan_rslt)); - } - else { - /* - * Use general assignment. - */ - impl = optab[asgn_loc].binary; - if (impl == NULL) { - nfatal(op, "assignment not implemented", NULL); - rslt = &ignore; /* make sure code generation can continue */ - } - else { - implproto(impl); - rslt = chk_alc(rslt, n->lifetime); - mk_callop(oper_name(impl), impl->ret_flag, asgn_var, 2, rslt,0); - } - } - } - else { - /* - * '?' - */ - rslt = scan_rslt; - } - - /* - * Produce code restore subject and pos when the body of the - * scanning expression succeeds. The new subject and pos must - * be saved in case of resumption. - */ - save_env(scanp->inner_sub, scanp->inner_pos); - restr_env(scanp->outer_sub, scanp->outer_pos); - - /* - * Produce code to handle resumption of string scanning. - */ - lbl = alc_lbl("scan resume", 0); - cd_add(lbl); - save_env(scanp->outer_sub, scanp->outer_pos); - restr_env(scanp->inner_sub, scanp->inner_pos); - cd_add(sig_cd(on_failure, cur_fnc)); /* fail */ - cur_fnc->cursor = lbl->prev; /* success continuation goes before label */ - on_failure = lbl; - - nxt_scan = scanp; - return rslt; - } - -/* - * gen_act - generate code for co-expression activation. - */ -static struct val_loc *gen_act(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct node *op; - struct node *transmit; - struct node *coexpr; - struct tmplftm *lifetm_ary; - struct val_loc *trans_loc; - struct val_loc *coexpr_loc; - struct val_loc *asgn1; - struct val_loc *asgn2; - struct val_loc *act_rslt; - struct lentry *c_single; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct implement *impl; - int c_deref; - int op_tok; - int tmp_indx; - - op = Tree0(n); /* operator node for '@' or '@:=' */ - transmit = Tree1(n); /* expression for value to transmit */ - coexpr = Tree2(n); /* expression for co-expression */ - op_tok = optab[Val0(op)].tok.t_type; - - /* - * Produce code for the value to be transmitted. - */ - if (op_tok == AUGAT) { - /* - * Augmented activation. This is seldom used so don't try too - * hard to optimize it. Allocate contiguous temporaries for - * the operands to the assignment. - */ - lifetm_ary = alc_lftm(2, &n->n_field[1]); - tmp_indx = alc_tmp(2, lifetm_ary); - asgn1 = tmp_loc(tmp_indx++); - asgn2 = tmp_loc(tmp_indx); - free((char *)lifetm_ary); - - /* - * Generate code to produce the left-hand-side of the assignment. - * This is also the transmitted value. Activation may need a - * dereferenced value, so this must be in a different location. - */ - gencode(transmit, asgn1); - trans_loc = chk_alc(NULL, n->intrnl_lftm); - setloc(op); - deref_ret(asgn1, trans_loc, varsubtyp(transmit->type, NULL)); - } - else - trans_loc = genretval(op, transmit, NULL); /* ordinary activation */ - - /* - * Determine if the value to be activated needs dereferencing, and - * see if it can only come from a single named variable. - */ - c_deref = HasVar(varsubtyp(coexpr->type, &c_single)); - if (c_single == NULL) { - /* - * The value is something other than a single named variable. - */ - coexpr_loc = gencode(coexpr, NULL); - if (c_deref) - deref_cd(coexpr_loc, coexpr_loc); - } - else { - /* - * The value is in a named variable. Use it directly from the - * variable rather than saving the result of the expression. - */ - gencode(coexpr, &ignore); - coexpr_loc = var_ref(c_single); - } - - /* - * Make sure the value to be activated is a co-expression. Perform - * run-time checking if necessary. - */ - cur_symtyps = n->symtyps; - if (eval_is(coexp_typ, 1) & MaybeFalse) { - lbl = alc_lbl("is co-expression", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "("; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = coexpr_loc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ").dword == D_Coexpr"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(118, &("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = coexpr_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = "));"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - - /* - * Make sure a result location has been allocated. For ordinary - * activation, this is where activate() puts its result. For - * augmented activation, this is where assignment puts its result. - */ - rslt = chk_alc(rslt, n->lifetime); - if (op_tok == AUGAT) - act_rslt = asgn2; - else - act_rslt = rslt; - - /* - * Generate code to call activate(). - */ - setloc(n); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(7); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "activate(&"; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = trans_loc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", (struct b_coexpr *)BlkLoc("; - cd1->ElemTyp(3) = A_ValLoc; - cd1->ValLoc(3) = coexpr_loc; - cd1->ElemTyp(4) = A_Str; - cd1->Str(4) = "), &"; - cd1->ElemTyp(5) = A_ValLoc; - cd1->ValLoc(5) = act_rslt; - cd1->ElemTyp(6) = A_Str; - cd1->Str(6) = ") == A_Resume"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - - /* - * For augmented activation, generate code to call assignment. - */ - if (op_tok == AUGAT) { - impl = optab[asgn_loc].binary; - if (impl == NULL) { - nfatal(op, "assignment not implemented", NULL); - rslt = &ignore; /* make sure code generation can continue */ - } - else { - implproto(impl); - mk_callop(oper_name(impl), impl->ret_flag, asgn1, 2, rslt, 0); - } - } - - return rslt; - } - -/* - * save_env - generate code to save scanning environment. - */ -static void save_env(sub_sav, pos_sav) -struct val_loc *sub_sav; -struct val_loc *pos_sav; - { - struct code *cd; - - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = sub_sav; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = k_subject;"; - cd_add(cd); - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = pos_sav; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = k_pos;"; - cd_add(cd); - } - -/* - * restr_env - generate code to restore scanning environment. - */ -static void restr_env(sub_sav, pos_sav) -struct val_loc *sub_sav; -struct val_loc *pos_sav; - { - struct code *cd; - - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_subject = "; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = sub_sav; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ";"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "k_pos = "; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = pos_sav; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ";"; - cd_add(cd); - } - -/* - * mk_callop - produce the code to directly call an operation. - */ -static void mk_callop(oper_nm, ret_flag, arg1rslt, nargs, rslt, optim) -char *oper_nm; -int ret_flag; -struct val_loc *arg1rslt; -int nargs; -struct val_loc *rslt; -int optim; - { - struct code *arg_lst; - struct code *on_ret; - struct c_fnc *fnc; - int n; - int need_cont; - - /* - * If this operation can return an "continue" signal, we will need - * a break statement in the signal switch to handle it. - */ - if (ret_flag & DoesRet) { - on_ret = NewCode(1); /* #fields == #fields C_Goto */ - on_ret->cd_id = C_Break; - on_ret->next = NULL; - on_ret->prev = NULL; - } - else - on_ret = NULL; - - /* - * Construct argument list for the C function implementing the - * operation. First compute the size of the code array for the - * argument list; this varies if we are using an optimized calling - * interface. - */ - if (optim) { - n = 0; - if (arg1rslt != NULL) - n += 2; - if (ret_flag & (DoesRet | DoesSusp)) { - if (n > 0) - ++n; - n += 2; - } - } - else - n = 7; - if (n == 0) - arg_lst = NULL; - else { - arg_lst = alc_ary(n); - n = 0; - if (!optim) { - arg_lst->ElemTyp(n) = A_Intgr; /* number of arguments */ - arg_lst->Intgr(n) = nargs; - ++n; - arg_lst->ElemTyp(n) = A_Str; /* , */ - arg_lst->Str(n) = ", "; - ++n; - } - if (arg1rslt == NULL) { /* location of first argument */ - if (!optim) { - arg_lst->ElemTyp(n) = A_Str; - arg_lst->Str(n) = "NULL"; - ++n; - arg_lst->ElemTyp(n) = A_Str; - arg_lst->Str(n) = ""; /* nothing, but must fill slot */ - ++n; - } - } - else { - arg_lst->ElemTyp(n) = A_Str; - arg_lst->Str(n) = "&"; - ++n; - arg_lst->ElemTyp(n) = A_ValLoc; - arg_lst->ValLoc(n) = arg1rslt; - ++n; - } - if (!optim || ret_flag & (DoesRet | DoesSusp)) { - if (n > 0) { - arg_lst->ElemTyp(n) = A_Str; /* , */ - arg_lst->Str(n) = ", "; - ++n; - } - arg_lst->ElemTyp(n) = A_Str; /* location of result */ - arg_lst->Str(n) = "&"; - ++n; - arg_lst->ElemTyp(n) = A_ValLoc; - arg_lst->ValLoc(n) = rslt; - } - } - - /* - * Generate code to call the operation and handle returned signals. - */ - if (ret_flag & DoesSusp) { - /* - * The operation suspends, so call it with a continuation, then - * proceed to generate code in the continuation. - */ - fnc = alc_fnc(); - callo_add(oper_nm, ret_flag, fnc, 1, arg_lst, on_ret); - if (ret_flag & DoesRet) - callc_add(fnc); - cur_fnc = fnc; - on_failure = &resume; - } - else { - /* - * No continuation is needed, but if standard calling conventions - * are used, a NULL continuation argument is required. - */ - if (optim) - need_cont = 0; - else - need_cont = 1; - callo_add(oper_nm, ret_flag, NULL, need_cont, arg_lst, on_ret); - } -} - -/* - * genretval - generate code for the expression in a return/suspend or - * for the expression for the value to be transmitted in a co-expression - * context switch. - */ -static struct val_loc *genretval(n, expr, dest) -struct node *n; -struct node *expr; -struct val_loc *dest; - { - int subtypes; - struct lentry *single; - struct val_loc *val; - - subtypes = varsubtyp(expr->type, &single); - - /* - * If we have a single local or argument, we don't need to construct - * a variable reference; we need the value and we know where it is. - */ - if (single != NULL && (subtypes & (HasLcl | HasPrm))) { - gencode(expr, &ignore); - val = var_ref(single); - if (dest == NULL) - dest = val; - else - cd_add(mk_cpyval(dest, val)); - } - else { - dest = gencode(expr, dest); - setloc(n); - deref_ret(dest, dest, subtypes); - } - - return dest; - } - -/* - * deref_ret - produced dereferencing code for values returned from - * procedures or transmitted to co-expressions. - */ -static void deref_ret(src, dest, subtypes) -struct val_loc *src; -struct val_loc *dest; -int subtypes; - { - struct code *cd; - struct code *lbl; - - if (src == NULL) - return; /* no value to dereference */ - - /* - * If there may be values that do not need dereferencing, insure that the - * values are in the destination and make it the source of dereferencing. - */ - if ((subtypes & (HasVal | HasGlb)) && (src != dest)) { - cd_add(mk_cpyval(dest, src)); - src = dest; - } - - if (subtypes & (HasLcl | HasPrm)) { - /* - * Some values may need to be dereferenced. - */ - lbl = NULL; - if (subtypes & HasVal) { - /* - * We may have a non-variable and must check at run time. - */ - lbl = check_var(dest, NULL); - } - - if (subtypes & HasGlb) { - /* - * Make sure we don't dereference any globals, use retderef(). - */ - if (subtypes & HasLcl) { - /* - * We must dereference any locals. - */ - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "retderef(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = dest; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = - ", (word *)pfp->tend.d, (word *)(pfp->tend.d + pfp->tend.num));"; - cd_add(cd); - /* - * We may now have a value. We must check at run-time and skip - * any attempt to dereference an argument. - */ - lbl = check_var(dest, lbl); - } - - if (subtypes & HasPrm) { - /* - * We must dereference any arguments. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "retderef(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = dest; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", (word *)glbl_argp, (word *)(glbl_argp + "; - cd->ElemTyp(3) = A_Intgr; - cd->Intgr(3) = Abs(cur_proc->nargs); - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "));"; - cd_add(cd); - } - } - else /* No globals */ - deref_cd(src, dest); - - if (lbl != NULL) - cur_fnc->cursor = lbl; /* continue after label */ - } - } - -/* - * check_var - generate code to make sure a descriptor contains a variable - * reference. If no label is given to jump to for a non-variable, allocate - * one and generate code before it. - */ -static struct code *check_var(d, lbl) -struct val_loc *d; -struct code *lbl; - { - struct code *cd, *cd1; - - if (lbl == NULL) { - lbl = alc_lbl("not variable", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - } - - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "!Var("; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = d; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ")"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - - return lbl; - } - -/* - * field_ref - generate code for a field reference. - */ -static struct val_loc *field_ref(n, rslt) -struct node *n; -struct val_loc *rslt; - { - struct node *rec; - struct node *fld; - struct fentry *fp; - struct par_rec *rp; - struct val_loc *rec_loc; - struct code *cd; - struct code *cd1; - struct code *lbl; - struct lentry *single; - int deref; - int num_offsets; - int offset; - int bad_recs; - - rec = Tree0(n); - fld = Tree1(n); - - /* - * Generate code to compute the record value and dereference it. - */ - deref = HasVar(varsubtyp(rec->type, &single)); - if (single != NULL) { - /* - * The record is in a named variable. Use value directly from - * the variable rather than saving the result of the expression. - */ - gencode(rec, &ignore); - rec_loc = var_ref(single); - } - else { - rec_loc = gencode(rec, NULL); - if (deref) - deref_cd(rec_loc, rec_loc); - } - - setloc(fld); - - /* - * Make sure the operand is a record. - */ - cur_symtyps = n->symtyps; - if (eval_is(rec_typ, 0) & MaybeFalse) { - lbl = alc_lbl("is record", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "("; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = rec_loc; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ").dword == D_Record"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(107, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rec_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - - rslt = chk_alc(rslt, n->lifetime); - - /* - * Find the list of records containing this field. - */ - if ((fp = flookup(Str0(fld))) == NULL) { - nfatal(n, "invalid field", Str0(fld)); - return rslt; - } - - /* - * Generate code for declarations and to get the record block pointer. - */ - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "{"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "struct b_record *r_rp = (struct b_record *) BlkLoc("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rec_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) { - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "int r_must_fail = 0;"; - cd_add(cd); - } - - /* - * Determine which records are in the record type. - */ - mark_recs(fp, cur_symtyps->types[0], &num_offsets, &offset, &bad_recs); - - /* - * Generate code to insure that the field belongs to the record - * and to index into the record block. - */ - if (num_offsets == 1 && !bad_recs) { - /* - * We already know the offset of the field. - */ - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".dword = D_Var + ((word *)&r_rp->fields["; - cd->ElemTyp(2) = A_Intgr; - cd->Intgr(2) = offset; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "] - (word *)r_rp);"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "VarLoc("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = (dptr)r_rp;"; - cd_add(cd); - for (rp = fp->rlist; rp != NULL; rp = rp->next) - rp->mark = 0; - } - else { - /* - * The field appears in several records. generate code to determine - * which one it is. - */ - - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "dptr r_dp;"; - cd_add(cd); - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "switch (r_rp->recdesc->proc.recnum) {"; - cd_add(cd); - - rp = fp->rlist; - while (rp != NULL) { - offset = rp->offset; - while (rp != NULL && rp->offset == offset) { - if (rp->mark) { - rp->mark = 0; - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " case "; - cd->ElemTyp(1) = A_Intgr; - cd->Intgr(1) = rp->rec->rec_num; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ":"; - cd_add(cd); - } - rp = rp->next; - } - - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " r_dp = &r_rp->fields["; - cd->ElemTyp(1) = A_Intgr; - cd->Intgr(1) = offset; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = "];"; - cd_add(cd); - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " break;"; - cd_add(cd); - } - - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " default:"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " err_msg(207, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rec_loc; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - cd_add(cd); - if (err_conv) { - /* - * The peephole analyzer doesn't know how to handle a goto or return - * in a switch statement, so just set a flag here. - */ - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " r_must_fail = 1;"; - cd_add(cd); - } - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = " }"; - cd_add(cd); - if (err_conv) { - /* - * Now that we are out of the switch statement, see if the flag - * was set to indicate error conversion. - */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "r_must_fail"; - cd->Cond = cd1; - cd->ThenStmt = sig_cd(on_failure, cur_fnc); - cd_add(cd); - } - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".dword = D_Var + ((word *)r_dp - (word *)r_rp);"; - cd_add(cd); - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "VarLoc("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = (dptr)r_rp;"; - cd_add(cd); - } - - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "}"; - cd_add(cd); - return rslt; - } - -/* - * bound - bound the code for the given sub-tree. If catch_fail is true, - * direct failure to the bounding label. - */ -static struct val_loc *bound(n, rslt, catch_fail) -struct node *n; -struct val_loc *rslt; -int catch_fail; - { - struct code *lbl1; - struct code *fail_sav; - struct c_fnc *fnc_sav; - - fnc_sav = cur_fnc; - fail_sav = on_failure; - - lbl1 = alc_lbl("bound", Bounding); - cd_add(lbl1); - cur_fnc->cursor = lbl1->prev; /* code goes before label */ - if (catch_fail) - on_failure = lbl1; - - rslt = gencode(n, rslt); - - cd_add(sig_cd(lbl1, cur_fnc)); /* transfer control to bounding label */ - cur_fnc = fnc_sav; - cur_fnc->cursor = lbl1; - - on_failure = fail_sav; - return rslt; - } - -/* - * cd_add - add a code struct at the cursor in the current function. - */ -void cd_add(cd) -struct code *cd; - { - register struct code *cursor; - - cursor = cur_fnc->cursor; - - cd->next = cursor->next; - cd->prev = cursor; - if (cursor->next != NULL) - cursor->next->prev = cd; - cursor->next = cd; - cur_fnc->cursor = cd; - } - -/* - * sig_cd - convert a signal/label into a goto or return signal in - * the context of the given function. - */ -struct code *sig_cd(sig, fnc) -struct code *sig; -struct c_fnc *fnc; - { - struct code *cd; - - if (sig->cd_id == C_Label && sig->Container == fnc) - return mk_goto(sig); - else { - cd = NewCode(1); /* # fields <= # fields of C_Goto */ - cd->cd_id = C_RetSig; - cd->next = NULL; - cd->prev = NULL; - cd->SigRef = add_sig(sig, fnc); - return cd; - } - } - -/* - * add_sig - add signal to list of signals returned by function. - */ -struct sig_lst *add_sig(sig, fnc) -struct code *sig; -struct c_fnc *fnc; - { - struct sig_lst *sl; - - for (sl = fnc->sig_lst; sl != NULL && sl->sig != sig; sl = sl->next) - ; - if (sl == NULL) { - sl = NewStruct(sig_lst); - sl->sig = sig; - sl->ref_cnt = 1; - sl->next = fnc->sig_lst; - fnc->sig_lst = sl; - } - else - ++sl->ref_cnt; - return sl; - } - -/* - * callc_add - add code to call a continuation. Note the action to be - * taken if the continuation returns resumption. The actual list - * signals returned and actions to take will be figured out after - * the continuation has been optimized. - */ -void callc_add(cont) -struct c_fnc *cont; - { - struct code *cd; - - cd = new_call(); - cd->OperName = NULL; - cd->Cont = cont; - cd->ArgLst = NULL; - cd->ContFail = on_failure; - cd->SigActs = NULL; - ++cont->ref_cnt; - } - -/* - * callo_add - add code to call an operation. - */ -void callo_add(oper_nm, ret_flag, cont, need_cont, arglist, on_ret) -char *oper_nm; -int ret_flag; -struct c_fnc *cont; -int need_cont; -struct code *arglist; -struct code *on_ret; - { - struct code *cd; - struct code *cd1; - - cd = new_call(); - cd->OperName = oper_nm; - cd->Cont = cont; - if (need_cont) - cd->Flags = NeedCont; - cd->ArgLst = arglist; - cd->ContFail = NULL; /* operation handles failure from the continuation */ - /* - * Decide how to handle the signals produced by the operation. (Those - * produced by the continuation will be examined after the continuation - * is optimized.) - */ - cd->SigActs = NULL; - if (MightFail(ret_flag)) - cd->SigActs = new_sgact(&resume, sig_cd(on_failure,cur_fnc), cd->SigActs); - if (ret_flag & DoesRet) - cd->SigActs = new_sgact(&contin, on_ret, cd->SigActs); - if (ret_flag & DoesFThru) { - cd1 = NewCode(1); /* #fields == #fields C_Goto */ - cd1->cd_id = C_Break; - cd1->next = NULL; - cd1->prev = NULL; - cd->SigActs = new_sgact(&fallthru, cd1, cd->SigActs); - } - if (cont != NULL) - ++cont->ref_cnt; /* increment reference count */ -} - -/* - * Create a call, add it to the code for the current function, and - * add it to the list of calls from the current function. - */ -static struct code *new_call() - { - struct code *cd; - - cd = NewCode(7); - cd->cd_id = C_CallSig; - cd_add(cd); - cd->Flags = 0; - cd->NextCall = cur_fnc->call_lst; - cur_fnc->call_lst = cd; - return cd; - } - -/* - * sig_act - create a new binding of an action to a signal. - */ -struct sig_act *new_sgact(sig, cd, next) -struct code *sig; -struct code *cd; -struct sig_act *next; - { - struct sig_act *sa; - - sa = NewStruct(sig_act); - sa->sig = sig; - sa->cd = cd; - sa->shar_act = NULL; - sa->next = next; - return sa; - } - - -#ifdef OptimizeLit -static int instr(const char *str, int chr) { - int i, found, go; - - found = 0; go = 1; - for(i=0; ((str[i] != '\0') && go) ;i++) { - if (str[i] == chr) { - go = 0; - found = 1; - if ((str[i+1] != '\0') && (chr == '=')) - if (str[i+1] == '=') - found = 0; - if ((chr == '=') && (i > 0)) { - if (str[i-1] == '>') - found = 0; - else if (str[i-1] == '<') - found = 0; - else if (str[i-1] == '!') - found = 0; - } - } - } - return found; -} - -static void tbl_add(struct lit_tbl *add) { - struct lit_tbl *ins; - static struct lit_tbl *ptr = NULL; - int go = 1; - - if (tbl == NULL) { - tbl = add; - ptr = add; - } - else { - ins = ptr; - while ((ins != NULL) && go) { - if (add->index != ins->index) - ins = ins->prev; - else - go = 0; - } - if (ins != NULL) { - if (ins->end == NULL) - ins->end = add->initial; - } - ptr->next = add; - add->prev = ptr; - ptr = add; - } -} - - -static void invalidate(struct val_loc *val, struct code *end, int code) { - struct lit_tbl *ptr, *back; - int index, go = 1; - - if (val == NULL) - return; - if (val->loc_type == V_NamedVar) { - index = val->u.nvar->val.index; - return; - } - else if (val->loc_type == V_Temp) - index = val->u.tmp + cur_proc->tnd_loc; - else - return; - if (tbl == NULL) - return; - back = tbl; - while (back->next != NULL) - back = back->next; - go = 1; - for(ptr=back; ((ptr != NULL) && go) ; ptr=ptr->prev) { - if ((ptr->index == index) && (ptr->modified != NO_TOUCH)) { - ptr->modified = code; - if ((code != LIMITED_TO_INT) && (ptr->safe)) { - ptr->end = end; - ptr->safe = 0; - } - go = 0; - } - else if ((ptr->index == index) && (ptr->modified == NO_TOUCH)) { - if ((code != LIMITED_TO_INT) && (ptr->safe)) { - ptr->end = end; - ptr->safe = 0; - } - go = 0; - } - else if (ptr->index == index) - go = 0; - } -} - - -static int eval_code(struct code *cd, struct lit_tbl *cur) { - struct code *tmp; - struct lit_tbl *tmp_tbl; - int i, j; - char *str; - - for (i=0; cd->ElemTyp(i) != A_End ;i++) { - switch(cd->ElemTyp(i)) { - case A_ValLoc: - if (cd->ValLoc(i)->mod_access != M_CInt) - break; - if ((cd->ValLoc(i)->u.tmp + cur_proc->tnd_loc) == cur->index) { - switch (cd->ValLoc(i)->loc_type) { - case V_Temp: - if (cur->csym->flag == F_StrLit) { -#if 0 - cd->ElemTyp(i) = A_Str; - str = (char *)alloc(strlen(cur->csym->image)+8); - sprintf(str, "\"%s\"/*Z*/", cur->csym->image); - cd->Str(i) = str; -#endif - } - else if (cur->csym->flag == F_IntLit) { - cd->ElemTyp(i) = A_Str; - cd->Str(i) = cur->csym->image; - } - break; - default: - break; - } - } - break; - case A_Ary: - for(tmp=cd->Array(i); tmp != NULL ;tmp=tmp->next) - eval_code(tmp, cur); - break; - default: - break; - } - } -} - -static void propagate_literals() { - struct lit_tbl *ptr; - struct code *cd, *arg; - int ret; - - for(ptr=tbl; ptr != NULL ;ptr=ptr->next) { - if (ptr->modified != NO_TOUCH) { - for(cd=ptr->initial; cd != ptr->end ;cd=cd->next) { - switch (cd->cd_id) { - case C_If: - for(arg=cd->Cond; arg != NULL ;arg=arg->next) - ret = eval_code(arg, ptr); - /* - * Again, don't take the 'then' portion. - * It might lead to infinite loops. - * for(arg=cd->ThenStmt; arg != NULL ;arg=arg->next) - * ret = eval_code(arg, ptr); - */ - break; - case C_CdAry: - ret = eval_code(cd, ptr); - break; - case C_CallSig: - for(arg=cd->ArgLst; arg != NULL ;arg=arg->next) - ret = eval_code(arg, ptr); - break; - default: - break; - } - } - } - } -} - -/* - * analyze_literals - analyzes the generated code to replace - * complex record dereferences with C - * literals. - */ -static void analyze_literals(struct code *start, struct code *top, int lvl) { - struct code *ptr, *tmp, *not_null; - struct lit_tbl *new_tbl; - struct lbl_tbl *new_lbl; - struct val_loc *prev = NULL; - int i, inc=0, addr=0, assgn=0, equal = 0; - - for (ptr = start; ptr != NULL ; ptr = ptr->next) { - if (!lvl) - not_null = ptr; - else - not_null = top; - switch (ptr->cd_id) { - case C_NamedVar: - break; - case C_CallSig: - analyze_literals(ptr->ArgLst, not_null, lvl+1); - break; - case C_Goto: - break; - case C_Label: - break; - case C_Lit: - new_tbl = alc_tbl(); - new_tbl->initial = ptr; - new_tbl->vloc = ptr->Rslt; - new_tbl->csym = ptr->Literal; - switch (ptr->Rslt->loc_type) { - case V_NamedVar: - new_tbl->index = ptr->Rslt->u.nvar->val.index; - tbl_add(new_tbl); - break; - case V_Temp: - new_tbl->index = ptr->Rslt->u.tmp + cur_proc->tnd_loc; - tbl_add(new_tbl); - break; - default: - new_tbl->index = -1; - free(new_tbl); - break; - } - break; - case C_If: - analyze_literals(ptr->Cond, not_null, lvl+1); - /* - * Don't analyze the 'then' portion such as in: - * analyze_literals(ptr->ThenStmt, not_null, lvl+1); - * Apparently, all the intermediate code does is maintain - * a pointer to where the flow of execution jumps to in - * case the 'then' is taken. These are all goto statments - * and can result in infinite loops of analyzation. - */ - break; - case C_CdAry: - for(i=0; ptr->ElemTyp(i) != A_End ;i++) { - switch(ptr->ElemTyp(i)) { - case A_Str: - if (ptr->Str(i) != NULL) { - if ( (strstr(ptr->Str(i), "-=")) || - (strstr(ptr->Str(i), "+=")) || - (strstr(ptr->Str(i), "*=")) || - (strstr(ptr->Str(i), "/=")) ) - invalidate(prev, not_null, NO_TOUCH); - else if (instr(ptr->Str(i), '=')) { - invalidate(prev, not_null, LIMITED); - assgn = 1; - } - else if ( (strstr(ptr->Str(i), "++")) || - (strstr(ptr->Str(i), "--")) ) - inc = 1; - else if (instr(ptr->Str(i), '&')) - addr = 1; - else if (strstr(ptr->Str(i), "==")) - equal = 1; - } - break; - case A_ValLoc: - if (inc) { - invalidate(ptr->ValLoc(i), not_null, NO_TOUCH); - inc = 0; - } - if (addr) { - invalidate(ptr->ValLoc(i), not_null, LIMITED); - addr = 0; - } - if ((assgn) && (ptr->ValLoc(i)->mod_access == M_None)) { - invalidate(ptr->ValLoc(i), not_null, LIMITED); - assgn = 0; - } - else if (assgn) - assgn = 0; - if (equal) { - invalidate(ptr->ValLoc(i), not_null, LIMITED_TO_INT); - equal = 0; - } - prev = ptr->ValLoc(i); - break; - case A_Intgr: - break; - case A_SBuf: - break; - case A_Ary: - for(tmp=ptr->Array(i); tmp != NULL ;tmp=tmp->next) - analyze_literals(tmp, not_null, lvl+1); - break; - default: - break; - } - } - break; - default: - break; - } - } -} -#endif /* OptimizeLit */ - -/* - * analyze_poll - analyzes the internal C code representation from - * the position of the last Poll() function call to - * the current position in the code. - * Returns a 0 if the last Poll() function should not - * be removed. - */ -#ifdef OptimizePoll -static int analyze_poll(void) { - struct code *cursor, *ptr; - int cont = 1; - - ptr = lastpoll; - if (ptr == NULL) - return 0; - cursor = cur_fnc->cursor; - while ((cursor != ptr) && (ptr != NULL) && (cont)) { - switch (ptr->cd_id) { - case C_Null : - case C_NamedVar : - case C_Label : - case C_Lit : - case C_Resume : - case C_Continue : - case C_FallThru : - case C_PFail : - case C_Goto : - case C_Create : - case C_If : - case C_SrcLoc : - case C_CdAry : - break; - case C_CallSig : - case C_RetSig : - case C_LBrack : - case C_RBrack : - case C_PRet : - case C_PSusp : - case C_Break : - cont = 0; - break; - } - ptr = ptr->next; - } - return cont; -} - -/* - * remove_poll - removes the ccode structure that represents the last - * call to the "Poll()" function by simply changing the code ID to - * C_Null code. - */ -static void remove_poll(void) { - - if (lastpoll == NULL) - return; - lastpoll->cd_id = C_Null; -} -#endif /* OptimizePoll */ - -/* - * setloc produces code to set the file name and line number to the - * source location of node n. Code is only produced if the corresponding - * value has changed since the last time setloc was called. - */ -static void setloc(n) -nodeptr n; - { - struct code *cd; - static int count=0; - - if (n == NULL || File(n) == NULL || Line(n) == 0) - return; - - if (File(n) != lastfiln || Line(n) != lastline) { -#ifdef OptimizePoll - if (analyze_poll()) - remove_poll(); - cd = alc_ary(1); - lastpoll = cd; -#else /* OptimizePoll */ - cd = alc_ary(1); -#endif /* OptimizePoll */ - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "Poll();"; - cd_add(cd); - - if (line_info) { - cd = NewCode(2); - cd->cd_id = C_SrcLoc; - - if (File(n) == lastfiln) - cd->FileName = NULL; - else { - lastfiln = File(n); - cd->FileName = lastfiln; - } - - if (Line(n) == lastline) - cd->LineNum = 0; - else { - lastline = Line(n); - cd->LineNum = lastline; - } - - cd_add(cd); - } - } - } - -/* - * alc_ary - create an array for a sequence of code fragments. - */ -struct code *alc_ary(n) -int n; - { - struct code *cd; - static cnt=1; - - cd = NewCode(2 * n + 1); - cd->cd_id = C_CdAry; - cd->next = NULL; - cd->prev = NULL; - cd->ElemTyp(n) = A_End; - return cd; - } - - -/* - * alc_lbl - create a label. - */ -struct code *alc_lbl(desc, flag) -char *desc; -int flag; - { - register struct code *cd; - - cd = NewCode(5); - cd->cd_id = C_Label; - cd->next = NULL; - cd->prev = NULL; - cd->Container = cur_fnc; /* function containing label */ - cd->SeqNum = 0; /* sequence number is allocated later */ - cd->Desc = desc; /* identifying comment */ - cd->RefCnt = 0; /* reference count */ - cd->LabFlg = flag; - return cd; - } - -/* - * alc_fnc - allocate a function structure; - */ -static struct c_fnc *alc_fnc() - { - register struct c_fnc *cf; - int i; - - cf = NewStruct(c_fnc); - cf->prefix[0] = '\0'; /* prefix is allocated later */ - cf->prefix[PrfxSz] = '\0'; /* terminate prefix for printing */ - cf->flag = 0; - for (i = 0; i < PrfxSz; ++i) - cf->frm_prfx[i] = frm_prfx[i]; /* note procedure frame prefix */ - cf->frm_prfx[PrfxSz] = '\0'; /* terminate prefix for printing */ - cf->cd.cd_id = C_Null; /* base of code sequence in function */ - cf->cd.next = NULL; - cf->cursor = &cf->cd; /* current place to insert code */ - cf->call_lst = NULL; /* functions called by this function */ - cf->creatlst = NULL; /* creates within this function */ - cf->sig_lst = NULL; /* signals returned by this function */ - cf->ref_cnt = 0; - cf->next = NULL; - *flst_end = cf; /* link entry onto global list */ - flst_end = &(cf->next); - return cf; - } - -/* - * tmp_loc - allocate a value location structure for nth temporary descriptor - * variable in procedure frame. - */ -static struct val_loc *tmp_loc(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_Temp; - r->mod_access = M_None; - r->u.tmp = n; - return r; - } - -/* - * itmp_loc - allocate a value location structure for nth temporary integer - * variable in procedure frame. - */ -struct val_loc *itmp_loc(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_ITemp; - r->mod_access = M_None; - r->u.tmp = n; - return r; - } - -/* - * dtmp_loc - allocate a value location structure for nth temporary double - * variable in procedure frame. - */ -struct val_loc *dtmp_loc(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_DTemp; - r->mod_access = M_None; - r->u.tmp = n; - return r; - } - -/* - * vararg_sz - allocate a value location structure that refers to the size - * of the variable part of an argument list. - */ -static struct val_loc *vararg_sz(n) -int n; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_Const; - r->mod_access = M_None; - r->u.int_const = n; - return r; - } - -/* - * cvar_loc - allocate a value location structure for a C variable. - */ -struct val_loc *cvar_loc(name) -char *name; - { - register struct val_loc *r; - - r = NewStruct(val_loc); - r->loc_type = V_CVar; - r->mod_access = M_None; - r->u.name = name; - return r; - } - -/* - * var_ref - allocate a value location structure for an Icon named variable. - */ -static struct val_loc *var_ref(sym) -struct lentry *sym; - { - struct val_loc *loc; - - loc = NewStruct(val_loc); - loc->loc_type = V_NamedVar; - loc->mod_access = M_None; - loc->u.nvar = sym; - return loc; - } - -/* - * deref_cd - generate code to dereference a descriptor. - */ -static void deref_cd(src, dest) -struct val_loc *src; -struct val_loc *dest; - { - struct code *cd; - - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "deref(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = src; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", &"; - cd->ElemTyp(3) = A_ValLoc; - cd->ValLoc(3) = dest; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ");"; - cd_add(cd); - } - -/* - * inv_op - directly invoke a run-time operation, in-lining it if possible. - */ -static struct val_loc *inv_op(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct implement *impl; - struct code *scont_strt; - struct code *scont_fail; - struct c_fnc *fnc; - struct val_loc *frst_arg; - struct val_loc *arg_rslt; - struct val_loc *r; - struct val_loc **varg_rslt; - struct op_symentry *symtab; - struct lentry **single; - struct tmplftm *lifetm_ary; - nodeptr rslt_lftm; - char *sbuf; - int *maybe_var; - int may_mod; - int nsyms; - int nargs; - int nparms; - int cont_loc; - int flag; - int refs; - int var_args; - int n_varargs; - int arg_loc; - int dcl_var; - int i; - int j; - int v; - - nargs = Val0(n); - impl = Impl1(n); - if (impl == NULL) { - /* - * We have already printed an error, just make sure we can - * continue. - */ - return &ignore; - } - - /* - * If this operation uses its result location as a work area, it must - * be given a tended result location and the value must be retained - * as long as the operation can be resumed. - */ - rslt_lftm = n->lifetime; - if (impl->use_rslt) { - rslt_lftm = max_lftm(rslt_lftm, n->intrnl_lftm); - if (rslt == &ignore) - rslt = NULL; /* force allocation of temporary */ - } - - /* - * Determine if this operation takes a variable number of arguments - * and determine the size of the variable part of the arg list. - */ - nparms = impl->nargs; - if (nparms > 0 && impl->arg_flgs[nparms - 1] & VarPrm) { - var_args = 1; - n_varargs = nargs - nparms + 1; - if (n_varargs < 0) - n_varargs = 0; - } - else { - var_args = 0; - n_varargs = 0; - } - - /* - * Construct a symbol table (implemented as an array) for the operation. - * The symbol table includes parameters, and both the tended and - * ordinary variables from the RTL declare statement. - */ - nsyms = (n->symtyps == NULL ? 0 : n->symtyps->nsyms); - if (var_args) - ++nsyms; - nsyms += impl->ntnds + impl->nvars; - if (nsyms > 0) - symtab = (struct op_symentry *)alloc((unsigned int)(nsyms * - sizeof(struct op_symentry))); - else - symtab = NULL; - for (i = 0; i < nsyms; ++i) { - symtab[i].n_refs = 0; /* number of non-modifying references */ - symtab[i].n_mods = 0; /* number of modifying references */ - symtab[i].n_rets = 0; /* number of times returned directly */ - symtab[i].var_safe = 0; /* Icon variable arg can be passed directly */ - symtab[i].adjust = 0; /* adjustments needed to "dereference" */ - symtab[i].itmp_indx = -1; /* loc after "in-place" convert to C integer */ - symtab[i].dtmp_indx = -1; /* loc after "in-place" convert to C double */ - symtab[i].loc = NULL; /* location as a descriptor */ - } - - /* - * If in-lining has not been disabled or the operation is a keyword, - * check to see if it can reasonably be in-lined and gather information - * needed to in-line it. - */ - if ((allow_inline || impl->oper_typ == 'K') && - do_inlin(impl, n, &cont_loc, symtab, n_varargs)) { - /* - * In-line the operation. - */ - - if (impl->ret_flag & DoesRet || impl->ret_flag & DoesSusp) - rslt = chk_alc(rslt, rslt_lftm); /* operation produces a result */ - - /* - * Allocate arrays to hold information from type inferencing about - * whether arguments are variables. This is used to optimize - * dereferencing. - */ - if (nargs > 0) { - maybe_var = (int *)alloc((unsigned int)(nargs * sizeof(int))); - single = (struct lentry **)alloc((unsigned int)(nargs * - sizeof(struct lentry *))); - } - - if (var_args) - --nparms; /* don't deal with varargs parameter yet. */ - - /* - * Match arguments with parameters and generate code for the - * arguments. The type of code generated depends on the kinds - * of dereferencing optimizations that are possible, though - * in general, dereferencing must wait until all arguments are - * computed. Because there may be both dereferenced and undereferenced - * parameters for an argument, the symbol table index does not always - * match the argument index. - */ - i = 0; /* symbol table index */ - for (j = 0; j < nparms && j < nargs; ++j) { - /* - * Use information from type inferencing to determine if the - * argument might me a variable and whether it is a single - * known named variable. - */ - maybe_var[j] = HasVar(varsubtyp(n->n_field[FrstArg + j].n_ptr->type, - &(single[j]))); - - /* - * Determine how many times the argument is referenced. If we - * optimize away return statements because we don't need the - * result, those references don't count. Take into account - * that there may be both dereferenced and undereferenced - * parameters for this argument. - */ - if (rslt == &ignore) - symtab[i].n_refs -= symtab[i].n_rets; - refs = symtab[i].n_refs + symtab[i].n_mods; - flag = impl->arg_flgs[j] & (RtParm | DrfPrm); - if (flag == (RtParm | DrfPrm)) - refs += symtab[i + 1].n_refs + symtab[i + 1].n_mods; - if (refs == 0) { - /* - * Indicate that we don't need the argument value (we must - * still perform the computation in case it has side effects). - */ - arg_rslt = &ignore; - symtab[i].adjust = AdjNone; - } - else { - /* - * Decide whether the result location for the argument can be - * used directly as the parameter. - */ - if (flag == (RtParm | DrfPrm) && symtab[i].n_refs + - symtab[i].n_mods == 0) { - /* - * We have both dereferenced and undereferenced parameters, - * but don't use the undereferenced one so ignore it. - */ - symtab[i].adjust = AdjNone; - ++i; - flag = DrfPrm; - } - if (flag == DrfPrm && single[j] != NULL) { - /* - * We need only a dereferenced value, but know what variable - * it is in. We don't need the computed argument value, we will - * get it directly from the variable. If it is safe to do - * so, we will pass a pointer to the variable as the argument - * to the operation. - */ - arg_rslt = &ignore; - symtab[i].loc = var_ref(single[j]); - if (symtab[i].var_safe) - symtab[i].adjust = AdjNone; - else - symtab[i].adjust = AdjCpy; - } - else { - /* - * Determine if the argument descriptor is modified by the - * operation; dereferencing a variable is a modification. - */ - may_mod = (symtab[i].n_mods != 0); - if (flag == DrfPrm) - may_mod |= maybe_var[j]; - if (n->n_field[FrstArg + j].n_ptr->reuse && may_mod) { - /* - * The parameter may be reused without recomputing - * the argument and the value may be modified. The - * argument result location and the parameter location - * must be separate so the parameter is reloaded upon - * each invocation. - */ - arg_rslt = chk_alc(NULL, - n->n_field[FrstArg + j].n_ptr->lifetime); - if (flag == DrfPrm && maybe_var[j]) - symtab[i].adjust = AdjNDrf; /* var: must dereference */ - else - symtab[i].adjust = AdjCpy; /* value only: just copy */ - } - else { - /* - * Argument result location will act as parameter location. - * Its lifetime must be as long as both that of the - * the argument and the parameter (operation internal - * lifetime). - */ - arg_rslt = chk_alc(NULL, max_lftm(n->intrnl_lftm, - n->n_field[FrstArg + j].n_ptr->lifetime)); - if (flag == DrfPrm && maybe_var[j]) - symtab[i].adjust = AdjDrf; /* var: must dereference */ - else - symtab[i].adjust = AdjNone; - } - symtab[i].loc = arg_rslt; - } - } - - /* - * Generate the code for the argument. - */ - gencode(n->n_field[FrstArg + j].n_ptr, arg_rslt); - - if (flag == (RtParm | DrfPrm)) { - /* - * We have computed the value for the undereferenced parameter, - * decide how to get the dereferenced value. - */ - ++i; - if (symtab[i].n_refs + symtab[i].n_mods == 0) - symtab[i].adjust = AdjNone; /* not needed, ignore */ - else { - if (single[j] != NULL) { - /* - * The value is in a specific Icon variable, get it from - * there. If is is safe to pass the variable directly - * to the operation, do so. - */ - symtab[i].loc = var_ref(single[j]); - if (symtab[i].var_safe) - symtab[i].adjust = AdjNone; - else - symtab[i].adjust = AdjCpy; - } - else { - /* - * If there might be a variable reference, note that it - * must be dereferenced. Otherwise decide whether the - * argument location can be used for both the dereferenced - * and undereferenced parameter. - */ - symtab[i].loc = arg_rslt; - if (maybe_var[j]) - symtab[i].adjust = AdjNDrf; - else if (symtab[i - 1].n_mods + symtab[i].n_mods == 0) - symtab[i].adjust = AdjNone; - else - symtab[i].adjust = AdjCpy; - } - } - } - ++i; - } - - /* - * Fill out parameter list with null values. - */ - while (j < nparms) { - int k, kn; - kn = 0; - if (impl->arg_flgs[j] & RtParm) - ++kn; - if (impl->arg_flgs[j] & DrfPrm) - ++kn; - for (k = 0; k < kn; ++k) { - if (symtab[i].n_refs + symtab[i].n_mods > 0) { - arg_rslt = chk_alc(NULL, n->intrnl_lftm); - cd_add(asgn_null(arg_rslt)); - symtab[i].loc = arg_rslt; - } - symtab[i].adjust = AdjNone; - ++i; - } - ++j; - } - - if (var_args) { - /* - * Compute variable part of argument list. - */ - ++nparms; /* add varargs parameter back into parameter list */ - - /* - * The variable part of the parameter list must be in contiguous - * descriptors. Create location and lifetime arrays for use in - * allocating the descriptors. - */ - if (n_varargs > 0) { - varg_rslt = (struct val_loc **)alloc((unsigned int)(n_varargs * - sizeof(struct val_loc *))); - lifetm_ary = alc_lftm(n_varargs, NULL); - } - - flag = impl->arg_flgs[j] & (RtParm | DrfPrm); - - /* - * Compute the lifetime of the elements of the varargs parameter array. - */ - for (v = 0; v < n_varargs; ++v) { - /* - * Use information from type inferencing to determine if the - * argument might me a variable and whether it is a single - * known named variable. - */ - maybe_var[j + v] = HasVar(varsubtyp( - n->n_field[FrstArg+j+v].n_ptr->type, &(single[j + v]))); - - /* - * Determine if the elements of the vararg parameter array - * might be modified. If it is a variable, dereferencing - * modifies it. - */ - may_mod = (symtab[j].n_mods != 0); - if (flag == DrfPrm) - may_mod |= maybe_var[j + v]; - - if ((flag == DrfPrm && single[j + v] != NULL) || - (n->n_field[FrstArg + j + v].n_ptr->reuse && may_mod)) { - /* - * The argument value is only placed in the vararg parameter - * array during "dereferencing". So the lifetime of the array - * element is the lifetime of the parameter and the element - * is not used until dereferencing. - */ - lifetm_ary[v].lifetime = n->intrnl_lftm; - lifetm_ary[v].cur_status = n->postn; - } - else { - /* - * The argument is computed into the vararg parameter array. - * The lifetime of the array element encompasses both - * the lifetime of the argument and the parameter. The - * element is used as soon as the argument is computed. - */ - lifetm_ary[v].lifetime = max_lftm(n->intrnl_lftm, - n->n_field[FrstArg+j+v].n_ptr->lifetime); - lifetm_ary[v].cur_status = n->n_field[FrstArg+j+v].n_ptr->postn; - } - } - - /* - * Allocate (reserve) the array of temporary variables for the - * vararg list. - */ - if (n_varargs > 0) { - arg_loc = alc_tmp(n_varargs, lifetm_ary); - free((char *)lifetm_ary); - } - - /* - * Generate code to compute arguments. - */ - for (v = 0; v < n_varargs; ++v) { - may_mod = (symtab[j].n_mods != 0); - if (flag == DrfPrm) - may_mod |= maybe_var[j + v]; - if (flag == DrfPrm && single[j + v] != NULL) { - /* - * We need a dereferenced value and it is in a known place: a - * named variable; don't bother saving the result of the - * argument computation. - */ - r = &ignore; - } - else if (n->n_field[FrstArg + j + v].n_ptr->reuse && may_mod) { - /* - * The argument can be reused without being recomputed and - * the parameter may be modified, so we cannot safely - * compute the argument into the vararg parameter array; we - * must compute it elsewhere and copy (dereference) it at the - * beginning of the operation. Let gencode allocate an argument - * result location. - */ - r = NULL; - } - else { - /* - * We can compute the argument directly into the vararg - * parameter array. - */ - r = tmp_loc(arg_loc + v); - } - varg_rslt[v] = gencode(n->n_field[FrstArg + j + v].n_ptr, r); - } - - setloc(n); - /* - * Dereference or copy argument values that are not already in vararg - * parameter list. Preceding arguments are dereferenced later, but - * it is okay if dereferencing is out-of-order. - */ - for (v = 0; v < n_varargs; ++v) { - if (flag == DrfPrm && single[j + v] != NULL) { - /* - * Copy the value from the known named variable into the - * parameter list. - */ - varg_rslt[v] = var_ref(single[j + v]); - cd_add(mk_cpyval(tmp_loc(arg_loc + v), varg_rslt[v])); - } - else if (flag == DrfPrm && maybe_var[j + v]) { - /* - * Dereference the argument into the parameter list. - */ - deref_cd(varg_rslt[v], tmp_loc(arg_loc + v)); - } - else if (arg_loc + v != varg_rslt[v]->u.tmp) { - /* - * The argument is a dereferenced value, but is not yet - * in the parameter list; copy it there. - */ - cd_add(mk_cpyval(tmp_loc(arg_loc + v), varg_rslt[v])); - } - tmp_status[arg_loc + v] = InUse; /* parameter location in use */ - } - - /* - * The vararg parameter gets the address of the first element - * in the variable part of the argument list and the size - * parameter gets the number of elements in the list. - */ - if (n_varargs > 0) { - free((char *)varg_rslt); - symtab[i].loc = tmp_loc(arg_loc); - } - else - symtab[i].loc = chk_alc(NULL, n); /* dummy arg location */ - symtab[i].loc->mod_access = M_Addr; - ++i; - symtab[i].loc = vararg_sz(n_varargs); - ++i; - } - else { - /* - * Compute extra arguments, but discard the results. - */ - while (j < nargs) { - gencode(n->n_field[FrstArg + j].n_ptr, &ignore); - ++j; - } - } - - if (nargs > 0) { - free((char *)maybe_var); - free((char *)single); - } - - /* - * If execution does not continue through the parameter evaluation, - * don't try to generate in-line code. A lack of parameter types - * will cause problems with some in-line type conversions. - */ - if (!past_prms(n)) - return rslt; - - setloc(n); - - dcl_var = i; - - /* - * Perform any needed copying or dereferencing. - */ - for (i = 0; i < nsyms; ++i) { - switch (symtab[i].adjust) { - case AdjNDrf: - /* - * Dereference into a new temporary which is used as the - * parameter. - */ - arg_rslt = chk_alc(NULL, n->intrnl_lftm); - deref_cd(symtab[i].loc, arg_rslt); - symtab[i].loc = arg_rslt; - break; - case AdjDrf: - /* - * Dereference in place. - */ - deref_cd(symtab[i].loc, symtab[i].loc); - break; - case AdjCpy: - /* - * Copy into a new temporary which is used as the - * parameter. - */ - arg_rslt = chk_alc(NULL, n->intrnl_lftm); - cd_add(mk_cpyval(arg_rslt, symtab[i].loc)); - symtab[i].loc = arg_rslt; - break; - case AdjNone: - break; /* nothing need be done */ - } - } - - switch (cont_loc) { - case SepFnc: - /* - * success continuation must be in a separate function. - */ - fnc = alc_fnc(); - sbuf = (char *)alloc((unsigned int)(strlen(impl->name) + 5)); - sprintf(sbuf, "end %s", impl->name); - scont_strt = alc_lbl(sbuf, 0); - cd_add(scont_strt); - cur_fnc->cursor = scont_strt->prev; /* put oper before label */ - gen_inlin(impl->in_line, rslt, &scont_strt, NULL, fnc, impl, - nsyms, symtab, n, dcl_var, n_varargs); - cur_fnc->cursor = scont_strt; - callc_add(fnc); - cur_fnc = fnc; - on_failure = &resume; - break; - case SContIL: - /* - * one suspend an no return: success continuation is put in-line. - */ - gen_inlin(impl->in_line, rslt, &scont_strt, &scont_fail, NULL, impl, - nsyms, symtab, n, dcl_var, n_varargs); - cur_fnc->cursor = scont_strt; - on_failure = scont_fail; - break; - case EndOper: - /* - * no suspends: success continuation goes at end of operation. - */ - - sbuf = (char *)alloc((unsigned int)(strlen(impl->name) + 5)); - sprintf(sbuf, "end %s", impl->name); - scont_strt = alc_lbl(sbuf, 0); - cd_add(scont_strt); - cur_fnc->cursor = scont_strt->prev; /* put operation before lbl */ - gen_inlin(impl->in_line, rslt, &scont_strt, NULL, NULL, impl, - nsyms, symtab, n, dcl_var, n_varargs); - cur_fnc->cursor = scont_strt; - break; - } - } - else { - /* - * Do not in-line operation. - */ - implproto(impl); - frst_arg = gen_args(n, 2, nargs); - setloc(n); - if (impl->ret_flag & (DoesRet | DoesSusp)) - rslt = chk_alc(rslt, rslt_lftm); - mk_callop(oper_name(impl), impl->ret_flag, frst_arg, nargs, rslt, - 0); - } - if (symtab != NULL) - free((char *)symtab); - return rslt; - } - -/* - * max_lftm - given two lifetimes (in the form of nodes) return the - * maximum one. - */ -static nodeptr max_lftm(n1, n2) -nodeptr n1; -nodeptr n2; - { - if (n1 == NULL) - return n2; - else if (n2 == NULL) - return n1; - else if (n1->postn > n2->postn) - return n1; - else - return n2; - } - -/* - * inv_prc - directly invoke a procedure. - */ -static struct val_loc *inv_prc(n, rslt) -nodeptr n; -struct val_loc *rslt; - { - struct pentry *proc; - struct val_loc *r; - struct val_loc *arg1rslt; - struct val_loc *var_part; - int *must_deref; - struct lentry **single; - struct val_loc **arg_rslt; - struct code *cd; - struct tmplftm *lifetm_ary; - char *sbuf; - int nargs; - int nparms; - int i, j; - int arg_loc; - int var_sz; - int var_loc; - - /* - * This procedure is implemented without argument list adjustment or - * dereferencing, so they must be done before the call. - */ - nargs = Val0(n); /* number of arguments */ - proc = Proc1(n); - nparms = Abs(proc->nargs); - - if (nparms > 0) { - must_deref = (int *)alloc((unsigned int)(nparms * sizeof(int))); - single = (struct lentry **)alloc((unsigned int)(nparms * - sizeof(struct lentry *))); - arg_rslt = (struct val_loc **)alloc((unsigned int)(nparms * - sizeof(struct val_loc *))); - } - - /* - * Allocate a work area of temporaries to use as argument list. If - * an argument can be reused without being recomputed, it must not - * be computed directly into the work area. It will be copied or - * dereferenced into the work area when execution reaches the - * operation. If an argument is a single named variable, it can - * be dereferenced directly into the argument location. These - * conditions affect when the temporary will receive a value. - */ - if (nparms > 0) - lifetm_ary = alc_lftm(nparms, NULL); - for (i = 0; i < nparms; ++i) - lifetm_ary[i].lifetime = n->intrnl_lftm; - for (i = 0; i < nparms && i < nargs; ++i) { - must_deref[i] = HasVar(varsubtyp(n->n_field[FrstArg + i].n_ptr->type, - &(single[i]))); - if (single[i] != NULL || n->n_field[FrstArg + i].n_ptr->reuse) - lifetm_ary[i].cur_status = n->postn; - else - lifetm_ary[i].cur_status = n->n_field[FrstArg + i].n_ptr->postn; - } - while (i < nparms) { - lifetm_ary[i].cur_status = n->postn; /* arg list extension */ - ++i; - } - if (proc->nargs < 0) - lifetm_ary[nparms - 1].cur_status = n->postn; /* variable part */ - - if (nparms > 0) { - arg_loc = alc_tmp(nparms, lifetm_ary); - free((char *)lifetm_ary); - } - if (proc->nargs < 0) - --nparms; /* treat variable part specially */ - for (i = 0; i < nparms && i < nargs; ++i) { - if (single[i] != NULL) - r = &ignore; /* we know where the dereferenced value is */ - else if (n->n_field[FrstArg + i].n_ptr->reuse) - r = NULL; /* let gencode allocate a new temporary */ - else - r = tmp_loc(arg_loc + i); - arg_rslt[i] = gencode(n->n_field[FrstArg + i].n_ptr, r); - } - - /* - * If necessary, fill out argument list with nulls. - */ - while (i < nparms) { - cd_add(asgn_null(tmp_loc(arg_loc + i))); - tmp_status[arg_loc + i] = InUse; - ++i; - } - - if (proc->nargs < 0) { - /* - * handle variable part of list. - */ - var_sz = nargs - nparms; - - if (var_sz > 0) { - lifetm_ary = alc_lftm(var_sz, &n->n_field[FrstArg + nparms]); - var_loc = alc_tmp(var_sz, lifetm_ary); - free((char *)lifetm_ary); - for (j = 0; j < var_sz; ++j) { - gencode(n->n_field[FrstArg + nparms + j].n_ptr, - tmp_loc(var_loc + j)); - } - } - } - else { - /* - * If there are extra arguments, compute them, but discard the - * results. - */ - while (i < nargs) { - gencode(n->n_field[FrstArg + i].n_ptr, &ignore); - ++i; - } - } - - setloc(n); - /* - * Dereference or copy argument values that are not already in argument - * list as dereferenced values. - */ - for (i = 0; i < nparms && i < nargs; ++i) { - if (must_deref[i]) { - if (single[i] == NULL) { - deref_cd(arg_rslt[i], tmp_loc(arg_loc + i)); - } - else { - arg_rslt[i] = var_ref(single[i]); - cd_add(mk_cpyval(tmp_loc(arg_loc + i), arg_rslt[i])); - } - } - else if (n->n_field[FrstArg + i].n_ptr->reuse) - cd_add(mk_cpyval(tmp_loc(arg_loc + i), arg_rslt[i])); - tmp_status[arg_loc + i] = InUse; - } - - if (proc->nargs < 0) { - var_part = tmp_loc(arg_loc + nparms); - tmp_status[arg_loc + nparms] = InUse; - if (var_sz <= 0) { - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "varargs(NULL, 0, &"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = var_part; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ");"; - } - else { - cd = alc_ary(7); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "varargs(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = tmp_loc(var_loc); - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", "; - cd->ElemTyp(3) = A_Intgr; - cd->Intgr(3) = var_sz; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", &"; - cd->ElemTyp(5) = A_ValLoc; - cd->ValLoc(5) = var_part; - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ");"; - } - cd_add(cd); - ++nparms; /* include variable part in call */ - } - - if (nparms > 0) { - free((char *)must_deref); - free((char *)single); - free((char *)arg_rslt); - } - - sbuf = (char *)alloc((unsigned int)(strlen(proc->name) + PrfxSz + 3)); - sprintf(sbuf, "P%s_%s", proc->prefix, proc->name); - if (nparms > 0) - arg1rslt = tmp_loc(arg_loc); - else - arg1rslt = NULL; - if (proc->ret_flag & (DoesRet | DoesSusp)) - rslt = chk_alc(rslt, n->lifetime); - mk_callop(sbuf, proc->ret_flag, arg1rslt, nargs, rslt, 1); - return rslt; - } - -/* - * endlife - link a temporary variable onto the list to be freed when - * execution reaches a node. - */ -static void endlife(kind, indx, old, n) -int kind; -int indx; -int old; -nodeptr n; - { - struct freetmp *freetmp; - - if ((freetmp = freetmp_pool) == NULL) - freetmp = NewStruct(freetmp); - else - freetmp_pool = freetmp_pool->next; - freetmp->kind = kind; - freetmp->indx = indx; - freetmp->old = old; - freetmp->next = n->freetmp; - n->freetmp = freetmp; - } - -/* - * alc_tmp - allocate a block of temporary variables with the given lifetimes. - */ -static int alc_tmp(num, lifetm_ary) -int num; -struct tmplftm *lifetm_ary; - { - int i, j, k; - register int status; - int *new_status; - int new_size; - - i = 0; - for (;;) { - if (i + num > status_sz) { - /* - * The status array is too small, expand it. - */ - new_size = status_sz + Max(num, status_sz); - new_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - k = 0; - while (k < status_sz) { - new_status[k] = tmp_status[k]; - ++k; - } - while (k < new_size) { - new_status[k] = NotAlloc; - ++k; - } - free((char *)tmp_status); - tmp_status = new_status; - status_sz = new_size; - } - for (j = 0; j < num; ++j) { - status = tmp_status[i + j]; - if (status != NotAlloc && - (status == InUse || status <= lifetm_ary[j].lifetime->postn)) - break; - } - /* - * Did we find a block of temporaries that we can use? - */ - if (j == num) { - while (--j >= 0) { - endlife(DescTmp, i + j, tmp_status[i + j], lifetm_ary[j].lifetime); - tmp_status[i + j] = lifetm_ary[j].cur_status; - } - if (i + num > num_tmp) - num_tmp = i + num; - return i; - } - ++i; - } - } - -/* - * alc_lftm - allocate an array of lifetime information for an argument - * list. - */ -static struct tmplftm *alc_lftm(num, args) -int num; -union field *args; - { - struct tmplftm *lifetm_ary; - int i; - - lifetm_ary = (struct tmplftm *)alloc((unsigned int)(num * - sizeof(struct tmplftm))); - if (args != NULL) - for (i = 0; i < num; ++i) { - lifetm_ary[i].cur_status = args[i].n_ptr->postn; /* reserved for arg */ - lifetm_ary[i].lifetime = args[i].n_ptr->lifetime; - } - return lifetm_ary; - } - -/* - * alc_itmp - allocate a temporary C integer variable. - */ -int alc_itmp(lifetime) -nodeptr lifetime; - { - int i, j; - int new_size; - - i = 0; - while (i < istatus_sz && itmp_status[i] == InUse) - ++i; - if (i >= istatus_sz) { - /* - * The status array is too small, expand it. - */ - free((char *)itmp_status); - new_size = istatus_sz * 2; - itmp_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - j = 0; - while (j < istatus_sz) - itmp_status[j++] = InUse; - while (j < new_size) - itmp_status[j++] = NotAlloc; - istatus_sz = new_size; - } - endlife(CIntTmp, i, NotAlloc, lifetime); - itmp_status[i] = InUse; - if (num_itmp < i + 1) - num_itmp = i + 1; - return i; - } - -/* - * alc_dtmp - allocate a temporary C integer variable. - */ -int alc_dtmp(lifetime) -nodeptr lifetime; - { - int i, j; - int new_size; - - i = 0; - while (i < dstatus_sz && dtmp_status[i] == InUse) - ++i; - if (i >= dstatus_sz) { - /* - * The status array is too small, expand it. - */ - free((char *)dtmp_status); - new_size = dstatus_sz * 2; - dtmp_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - j = 0; - while (j < dstatus_sz) - dtmp_status[j++] = InUse; - while (j < new_size) - dtmp_status[j++] = NotAlloc; - dstatus_sz = new_size; - } - endlife(CDblTmp, i, NotAlloc, lifetime); - dtmp_status[i] = InUse; - if (num_dtmp < i + 1) - num_dtmp = i + 1; - return i; - } - -/* - * alc_sbufs - allocate a block of string buffers with the given lifetime. - */ -int alc_sbufs(num, lifetime) -int num; -nodeptr lifetime; - { - int i, j, k; - int *new_status; - int new_size; - - i = 0; - for (;;) { - if (i + num > sstatus_sz) { - /* - * The status array is too small, expand it. - */ - new_size = sstatus_sz + Max(num, sstatus_sz); - new_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - k = 0; - while (k < sstatus_sz) { - new_status[k] = sbuf_status[k]; - ++k; - } - while (k < new_size) { - new_status[k] = NotAlloc; - ++k; - } - free((char *)sbuf_status); - sbuf_status = new_status; - sstatus_sz = new_size; - } - for (j = 0; j < num && sbuf_status[i + j] == NotAlloc; ++j) - ; - /* - * Did we find a block of buffers that we can use? - */ - if (j == num) { - while (--j >= 0) { - endlife(SBuf, i + j, sbuf_status[i + j], lifetime); - sbuf_status[i + j] = InUse; - } - if (i + num > num_sbuf) - num_sbuf = i + num; - return i; - } - ++i; - } - } - -/* - * alc_cbufs - allocate a block of cset buffers with the given lifetime. - */ -int alc_cbufs(num, lifetime) -int num; -nodeptr lifetime; - { - int i, j, k; - int *new_status; - int new_size; - - i = 0; - for (;;) { - if (i + num > cstatus_sz) { - /* - * The status array is too small, expand it. - */ - new_size = cstatus_sz + Max(num, cstatus_sz); - new_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); - k = 0; - while (k < cstatus_sz) { - new_status[k] = cbuf_status[k]; - ++k; - } - while (k < new_size) { - new_status[k] = NotAlloc; - ++k; - } - free((char *)cbuf_status); - cbuf_status = new_status; - cstatus_sz = new_size; - } - for (j = 0; j < num && cbuf_status[i + j] == NotAlloc; ++j) - ; - /* - * Did we find a block of buffers that we can use? - */ - if (j == num) { - while (--j >= 0) { - endlife(CBuf, i + j, cbuf_status[i + j], lifetime); - cbuf_status[i + j] = InUse; - } - if (i + num > num_cbuf) - num_cbuf = i + num; - return i; - } - ++i; - } - } diff --git a/src/iconc/ccode.h b/src/iconc/ccode.h deleted file mode 100644 index 2d0cb6f..0000000 --- a/src/iconc/ccode.h +++ /dev/null @@ -1,252 +0,0 @@ -/* - * ccode.h - definitions used in code generation. - */ - -/* - * ChkPrefix - allocate a prefix to x if it has not already been done. - */ -#define ChkPrefix(x) if ((x)[0] == '\0') nxt_pre(x, pre, PrfxSz); - -/* - * sig_act - list of possible signals returned by a call and the action to be - * to be taken when the signal is returned: in effect a switch statement. - */ -struct sig_act { - struct code *sig; /* signal */ - struct code *cd; /* action to be taken: goto, return, break */ - struct sig_act *shar_act; /* signals that share this action */ - struct sig_act *next; - }; - -/* - * val_loc - location of a value. Used for intermediate and final results - * of expressions. - */ -#define V_NamedVar 1 /* Icon named variable indicated by nvar */ -#define V_Temp 2 /* temporary variable indicated by tmp */ -#define V_ITemp 3 /* C integer temporary variable indicated by tmp */ -#define V_DTemp 4 /* C double temporary variable indicated by tmp */ -#define V_PRslt 5 /* procedure result location */ -#define V_Const 6 /* integer constant - used for size of varargs */ -#define V_CVar 7 /* C named variable */ -#define V_Ignore 8 /* "trashcan" - a write-only location */ - -#define M_None 0 /* access simply as descriptor */ -#define M_CharPtr 1 /* access v-word as "char *" */ -#define M_BlkPtr 2 /* access v-word as block pointer using blk_name */ -#define M_CInt 3 /* access v-word as C integer */ -#define M_Addr 4 /* address of descriptor for varargs */ - -struct val_loc { - int loc_type; /* manifest constants V_* */ - int mod_access; /* manifest constants M_* */ - char *blk_name; /* used with M_BlkPtr */ - union { - struct lentry *nvar; /* Icon named variable */ - int tmp; /* index of temporary variable */ - int int_const; /* integer constant value */ - char *name; /* C named variable */ - } u; - }; - -/* - * "code" contains the information needed to print a piece of C code. - * C_... manifest constants are cd_id's. These are followed by - * corresponding field access expressions. - */ -#define Rslt fld[0].vloc /* place to put result of expression */ -#define Cont fld[1].fnc /* continuation function or null */ - -#define C_Null 0 /* no code */ - -#define C_NamedVar 1 /* reference to a named variable */ -/* uses Rslt */ -#define NamedVar fld[1].nvar - -#define C_CallSig 2 /* call and handling of returned signal */ -#define OperName fld[0].oper_nm /* run-time routine name or null */ -/* uses Cont */ -#define Flags fld[2].n /* flag: NeedCont, ForeignSig */ -#define ArgLst fld[3].cd /* argument list */ -#define ContFail fld[4].cd /* label/signal to goto/return on failure */ -#define SigActs fld[5].sa /* actions to take for returned signals */ -#define NextCall fld[6].cd /* for chaining calls within a continuation*/ -#define NeedCont 1 /* pass NULL continuation if Cont == NULL */ -#define ForeignSig 2 /* may get foreign signal from a suspend */ - -#define C_RetSig 3 /* return signal */ -#define SigRef fld[0].sigref /* pointer to func's reference to signal */ - -#define C_Goto 4 /* goto label */ -#define Lbl fld[0].cd /* label */ - -#define C_Label 5 /* statment label "Ln:" and signal "n" */ -#define Container fld[0].fnc /* continuation containing label */ -#define SeqNum fld[1].n /* sequence number, n */ -#define Desc fld[2].s /* description of how label/signal is used */ -#define RefCnt fld[3].n /* reference count for label */ -#define LabFlg fld[4].n /* flag: FncPtrd, BndSig */ -#define FncPrtd 1 /* function sig_n has been printed */ -#define Bounding 2 /* this is a bounding label */ - -#define C_Lit 6 /* literal (integer, real, string, cset) */ -/* uses Rslt */ -#define Literal fld[1].lit - -#define C_Resume 7 /* resume signal */ -#define C_Continue 8 /* continue signal */ -#define C_FallThru 9 /* fall through signal */ -#define C_PFail 10 /* procedure failure */ -#define C_PRet 11 /* procedure return (result already set) */ -#define C_PSusp 12 /* procedure suspend */ -#define C_Break 13 /* break out of signal handling switch */ -#define C_LBrack 14 /* '{' */ -#define C_RBrack 15 /* '}' */ - -#define C_Create 16 /* call of create() for create expression */ -/* uses Rslt */ -/* uses Cont */ -#define NTemps fld[2].n /* number of temporary descriptors needed */ -#define WrkSize fld[3].n /* size of non-descriptor work area */ -#define NextCreat fld[4].cd /* for chaining creates in a continuation */ - - -#define C_If 17 /* conditional (goto or return) */ -#define Cond fld[0].cd /* condition */ -#define ThenStmt fld[1].cd /* what to do if condition is true */ - -#define C_SrcLoc 18 -#define FileName fld[0].s /* name of source file */ -#define LineNum fld[1].n /* line number within source file */ - -#define C_CdAry 19 /* array of code pieces, each with type code*/ -#define A_Str 0 /* code represented as a string */ -#define A_ValLoc 1 /* value location */ -#define A_Intgr 2 /* integer */ -#define A_ProcCont 3 /* procedure continuation */ -#define A_SBuf 4 /* string buffer (integer index) */ -#define A_CBuf 5 /* cset buffer (integer index) */ -#define A_Ary 6 /* pointer to subarray of code pieces */ -#define A_End 7 /* marker for end of array */ -#define ElemTyp(i) fld[2*i].n /* type of element i (A_* codes) */ -#define Str(i) fld[2*i+1].s /* string in element i */ -#define ValLoc(i) fld[2*i+1].vloc /* value location in element i */ -#define Intgr(i) fld[2*i+1].n /* integer in element i */ -#define Array(i) fld[2*i+1].cd /* pointer to subarray in element i */ - -/* - * union cd_fld - fields within a code struct. - */ -union cd_fld { - int n; /* various integer values */ - char *s; /* various string values */ - struct lentry *nvar; /* symbol table entry for a named variable */ - struct code *cd; /* various pointers to other pieces of code */ - struct c_fnc *fnc; /* pointer to function information */ - struct centry *lit; /* symbol table entry for a literal */ - struct sig_act *sa; /* actions to take for a returned signal */ - struct sig_lst *sigref; /* pointer to func's reference to signal */ - struct val_loc *vloc; /* value location */ - char *oper_nm; /* name of run-time operation or NULL */ - }; - -/* - * code - struct used to hold the internal representation of generated code. - */ -struct code { - int cd_id; /* kind of code: C_* */ - struct code *next; /* next code fragment in list */ - struct code *prev; /* previous code fragment in list */ - union cd_fld fld[1]; /* fields of code fragment, actual number varies */ - }; - -/* - * NewCode - allocate a code structure with "size" fields. - */ -#define NewCode(size) (struct code *)alloc((unsigned int)\ - (sizeof(struct code) + (size-1) * sizeof(union cd_fld))) - -/* - * c_fnc contains information about a C function that implements a continuation. - */ -#define CF_SigOnly 1 /* this function only returns a signal */ -#define CF_ForeignSig 2 /* may return foreign signal from a suspend */ -#define CF_Mark 4 /* this function has been visited by fix_fncs() */ -#define CF_Coexpr 8 /* this function implements a co-expression */ -struct c_fnc { - char prefix[PrfxSz+1]; /* function prefix */ - char frm_prfx[PrfxSz+1]; /* procedure frame prefix */ - int flag; /* CF_* flags */ - struct code cd; /* start of code sequence */ - struct code *cursor; /* place to insert more code into sequence */ - struct code *call_lst; /* functions called by this function */ - struct code *creatlst; /* list of creates in this function */ - struct sig_lst *sig_lst; /* signals returned by this function */ - int ref_cnt; /* reference count for this function */ - struct c_fnc *next; - }; - - -/* - * sig_lst - a list of signals returned by a continuation along with a count - * of the number of places each signal is returned. - */ -struct sig_lst { - struct code *sig; /* signal */ - int ref_cnt; /* number of places returned */ - struct sig_lst *next; - }; - -/* - * op_symentry - entry in symbol table for an operation - */ -#define AdjNone 1 /* no adjustment to this argument */ -#define AdjDrf 2 /* deref in place */ -#define AdjNDrf 3 /* deref into a new temporary */ -#define AdjCpy 4 /* copy into a new temporary */ -struct op_symentry { - int n_refs; /* number of non-modifying references */ - int n_mods; /* number of modifying referenced */ - int n_rets; /* number of times directly returned from operation */ - int var_safe; /* if arg is named var, it may be used directly */ - int adjust; /* AdjNone, AdjInplc, or AdjToNew */ - int itmp_indx; /* index of temporary C integer variable */ - int dtmp_indx; /* index of temporary C double variable */ - struct val_loc *loc; - }; - -extern int num_tmp; /* number of temporary descriptor variables */ -extern int num_itmp; /* number of temporary C integer variables */ -extern int num_dtmp; /* number of temporary C double variables */ -extern int num_sbuf; /* number of string buffers */ -extern int num_cbuf; /* number of cset buffers */ - -extern struct code *bound_sig; /* bounding signal for current procedure */ - -/* - * statically declared "signals". - */ -extern struct code resume; -extern struct code contin; -extern struct code fallthru; -extern struct code next_fail; - -extern struct val_loc ignore; /* no values, just something to point at */ -extern struct c_fnc *cur_fnc; /* C function currently being built */ -extern struct code *on_failure; /* place to go on failure */ - -extern int lbl_seq_num; /* next label sequence number */ - -extern char pre[PrfxSz]; /* next unused prefix */ - -extern struct op_symentry *cur_symtab; /* current operation symbol table */ - -#define SepFnc 1 /* success continuation goes in separate function */ -#define SContIL 2 /* in line success continuation */ -#define EndOper 3 /* success continuation goes at end of operation */ - -#define HasVal 1 /* type contains values */ -#define HasLcl 2 /* type contains local variables */ -#define HasPrm 4 /* type contains parameters */ -#define HasGlb 8 /* type contains globals (including statics and elements) */ -#define HasVar(x) ((x) & (HasLcl | HasPrm | HasGlb)) diff --git a/src/iconc/ccomp.c b/src/iconc/ccomp.c deleted file mode 100644 index 5b86189..0000000 --- a/src/iconc/ccomp.c +++ /dev/null @@ -1,130 +0,0 @@ -/* - * ccomp.c - routines for compiling and linking the C program produced - * by the translator. - */ -#include "../h/gsupport.h" -#include "cglobals.h" -#include "ctrans.h" -#include "ctree.h" -#include "ccode.h" -#include "csym.h" -#include "cproto.h" - -extern char *refpath; - -#define ExeFlag "-o" -#define LinkLibs " -lm" - -/* - * Structure to hold the list of Icon run-time libraries that must be - * linked in. - */ -struct lib { - char *libname; - int nm_sz; - struct lib *next; - }; -static struct lib *liblst; -static int lib_sz = 0; - -/* - * addlib - add a new library to the list the must be linked. - */ -void addlib(libname) -char *libname; - { - static struct lib **nxtlib = &liblst; - struct lib *l; - - l = NewStruct(lib); - l->libname = libname; - l->nm_sz = strlen(libname); - l->next = NULL; - *nxtlib = l; - nxtlib = &l->next; - lib_sz += l->nm_sz + 1; - } - -/* - * ccomp - perform C compilation and linking. - */ -int ccomp(srcname, exename) -char *srcname; -char *exename; - { - struct lib *l; - char sbuf[MaxPath]; /* file name construction buffer */ - char *buf; - char *s; - char *dlrgint; - int cmd_sz, opt_sz, flg_sz, exe_sz, src_sz; - - /* - * Compute the sizes of the various parts of the command line - * to do the compilation. - */ - cmd_sz = strlen(c_comp); - opt_sz = strlen(c_opts); - flg_sz = strlen(ExeFlag); - exe_sz = strlen(exename); - src_sz = strlen(srcname); - lib_sz += strlen(LinkLibs); - if (!largeints) { - dlrgint = makename(sbuf, refpath, "dlrgint", ObjSuffix); - lib_sz += strlen(dlrgint) + 1; - } - -#ifdef Graphics - lib_sz += strlen(" -L") + - strlen(refpath) + - strlen(" -lIgpx "); - lib_sz += strlen(ICONC_XLIB); -#endif /* Graphics */ - - buf = alloc((unsigned int)cmd_sz + opt_sz + flg_sz + exe_sz + src_sz + - lib_sz + 5); - strcpy(buf, c_comp); - s = buf + cmd_sz; - *s++ = ' '; - strcpy(s, c_opts); - s += opt_sz; - *s++ = ' '; - strcpy(s, ExeFlag); - s += flg_sz; - *s++ = ' '; - strcpy(s, exename); - s += exe_sz; - *s++ = ' '; - strcpy(s, srcname); - s += src_sz; - if (!largeints) { - *s++ = ' '; - strcpy(s, dlrgint); - s += strlen(dlrgint); - } - for (l = liblst; l != NULL; l = l->next) { - *s++ = ' '; - strcpy(s, l->libname); - s += l->nm_sz; - } - -#ifdef Graphics - strcpy(s," -L"); - strcat(s, refpath); - strcat(s," -lIgpx "); - strcat(s, ICONC_XLIB); - s += strlen(s); -#endif /* Graphics */ - - strcpy(s, LinkLibs); - - if (system(buf) != 0) - return EXIT_FAILURE; - strcpy(buf, "strip "); - s = buf + 6; - strcpy(s, exename); - system(buf); - - - return EXIT_SUCCESS; - } diff --git a/src/iconc/cglobals.h b/src/iconc/cglobals.h deleted file mode 100644 index 301a602..0000000 --- a/src/iconc/cglobals.h +++ /dev/null @@ -1,50 +0,0 @@ -/* - * Global variables. - */ - -extern char *runtime; - -#ifndef Global -#define Global extern -#define Init(v) -#endif /* Global */ - -/* - * Variables related to command processing. - */ -Global char *progname Init("iconc"); /* program name for diagnostics */ - -Global int debug_info Init(0); /* -fd, -t: generate debugging info */ -Global int err_conv Init(0); /* -fe: support error conversion */ - -#ifdef LargeInts - Global int largeints Init(1); /* -fl: support large integers */ -#else /* LargeInts */ - Global int largeints Init(0); /* -fl: support large integers */ -#endif /* LargeInts */ - -Global int line_info Init(0); /* -fn, -fd, -t: generate line info */ -Global int m4pre Init(0); /* -m: use m4 preprocessor? */ -Global int str_inv Init(0); /* -fs: enable full string invocation */ -Global int trace Init(0); /* -t: initial &trace value */ -Global int uwarn Init(0); /* -u: warn about undefined ids? */ -Global int just_type_trace Init(0); /* -T: suppress C code */ -Global int verbose Init(1); /* -s, -v: level of verbosity */ -Global int pponly Init(0); /* -E: preprocess only */ - -Global char *c_comp Init(CComp); /* -C: C compiler */ -Global char *c_opts Init(COpts); /* -p: options for C compiler */ - -/* - * Flags turned off by the -n option. - */ -Global int opt_cntrl Init(1); /* do control flow optimization */ -Global int opt_sgnl Init(1); /* do signal handling optimizations */ -Global int do_typinfer Init(1); /* do type inference */ -Global int allow_inline Init(1); /* allow expanding operations in line */ - -/* - * Files. - */ -Global FILE *codefile Init(0); /* C code output - primary file */ -Global FILE *inclfile Init(0); /* C code output - include file */ diff --git a/src/iconc/cgrammar.c b/src/iconc/cgrammar.c deleted file mode 100644 index a48e621..0000000 --- a/src/iconc/cgrammar.c +++ /dev/null @@ -1,221 +0,0 @@ -/* - * cgrammar.c - includes and macros for building the parse tree. - */ -#include "../h/define.h" -#include "../common/yacctok.h" - -%{ -/* - * These commented directives are passed through the first application - * of cpp, then turned into real directives in cgram.g by fixgram.icn. - */ -/*#include "../h/gsupport.h"*/ -/*#include "../h/lexdef.h"*/ -/*#include "ctrans.h"*/ -/*#include "csym.h"*/ -/*#include "ctree.h"*/ -/*#include "ccode.h" */ -/*#include "cproto.h"*/ -/*#undef YYSTYPE*/ -/*#define YYSTYPE nodeptr*/ -/*#define YYMAXDEPTH 500*/ - -int idflag; - -#define EmptyNode tree1(N_Empty) - -#define Alt(x1,x2,x3) $$ = tree4(N_Alt,x2,x1,x3) -#define Apply(x1,x2,x3) $$ = tree4(N_Apply,x2,x1,x3) -#define Arglist1() /* empty */ -#define Arglist2(x) /* empty */ -#define Arglist3(x1,x2,x3) proc_lst->nargs = -proc_lst->nargs -#define Bact(x1,x2,x3) $$ = tree5(N_Activat,x2,x2,x1,x3) -#define Bamper(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bassgn(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Baugact(x1,x2,x3) $$ = tree5(N_Activat,x2,x2,x1,x3) -#define Baugamper(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugcat(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugeq(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugeqv(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugge(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bauggt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bauglcat(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugle(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bauglt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugne(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugneqv(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugques(x1,x2,x3) $$ = tree5(N_Scan,x2,x2,x1,x3) -#define Baugseq(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugsge(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugsgt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugsle(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugslt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Baugsne(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bcaret(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bcareta(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bcat(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bdiff(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bdiffa(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Beq(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Beqv(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bge(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bgt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Binter(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bintera(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Blcat(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Ble(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Blim(x1,x2,x3) $$ = tree4(N_Limit,x2,x1,x3) -#define Blt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bminus(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bminusa(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bmod(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bmoda(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bne(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bneqv(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bplus(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bplusa(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bques(x1,x2,x3) $$ = tree5(N_Scan,x2,x2,x1,x3) -#define Brace(x1,x2,x3) $$ = x2 -#define Brack(x1,x2,x3) $$ = list_nd(x1,x2) -#define Brassgn(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Break(x1,x2) $$ = tree3(N_Break,x1,x2) -#define Brswap(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bseq(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bsge(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bsgt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bslash(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bslasha(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bsle(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bslt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bsne(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bstar(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bstara(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Bswap(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Bunion(x1,x2,x3) $$ = binary_nd(x2,x1,x3) -#define Buniona(x1,x2,x3) $$ = aug_nd(x2,x1,x3) -#define Case(x1,x2,x3,x4,x5,x6) $$ = case_nd(x1,x2,x5) -#define Caselist(x1,x2,x3) $$ = tree4(N_Clist,x2,x1,x3) -#define Cclause0(x1,x2,x3) $$ = tree4(N_Ccls,x2,x1,x3) -#define Cclause1(x1,x2,x3) $$ = tree4(N_Ccls,x2,x1,x3) -#define Cliter(x) CSym0(x) = putlit(Str0(x),F_CsetLit,(int)Val1(x)) -#define Colon(x) $$ = x -#define Compound(x1,x2,x3) $$ = tree4(N_Slist,x2,x1,x3) -#define Create(x1,x2) $$ = tree3(N_Create,x1,x2);\ - proc_lst->has_coexpr = 1; -#define Elst0(x) $$ = x; -#define Elst1(x1,x2,x3) $$ = tree4(N_Elist,x2,x1,x3); -#define Every0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) -#define Every1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) -#define Fail(x) $$ = tree4(N_Ret,x,x,EmptyNode) -#define Field(x1,x2,x3) $$ = tree4(N_Field,x2,x1,x3) -#define Global0(x) idflag = F_Global -#define Global1(x1,x2,x3) /* empty */ -#define Globdcl(x) /* empty */ -#define Ident(x) install(Str0(x),idflag) -#define Idlist(x1,x2,x3) install(Str0(x3),idflag) -#define If0(x1,x2,x3,x4) $$ = tree5(N_If,x1,x2,x4,EmptyNode) -#define If1(x1,x2,x3,x4,x5,x6) $$ = tree5(N_If,x1,x2,x4,x6) -#define Iliter(x) CSym0(x) = putlit(Str0(x),F_IntLit,0) -#define Initial1() $$ = EmptyNode -#define Initial2(x1,x2,x3) $$ = x2 -#define Invocdcl(x) /* empty */ -#define Invocable(x1,x2) /* empty */ -#define Invoclist(x1,x2, x3) /* empty */ -#define Invocop1(x) invoc_grp(Str0(x)); -#define Invocop2(x) invocbl(x, -1); -#define Invocop3(x1,x2,x3) invocbl(x1, atoi(Str0(x3))); -#define Invoke(x1,x2,x3,x4) $$ = invk_nd(x2,x1,x3) -#define Keyword(x1,x2) $$ = key_leaf(x1,Str0(x2)) -#define Kfail(x1,x2) $$ = key_leaf(x1,spec_str("fail")) -#define Link(x1,x2) /* empty */ -#define Linkdcl(x) /* empty */ -#define Lnkfile1(x) lnkdcl(Str0(x)); -#define Lnkfile2(x) lnkdcl(Str0(x)); -#define Lnklist(x1,x2,x3) /* empty */ -#define Local(x) idflag = F_Dynamic -#define Locals1() /* empty */ -#define Locals2(x1,x2,x3,x4) /* empty */ -#define Mcolon(x) $$ = x -#define Nexpr() $$ = EmptyNode -#define Next(x) $$ = tree2(N_Next,x) -#define Paren(x1,x2,x3) if ((x2)->n_type == N_Elist)\ - $$ = invk_nd(x1,EmptyNode,x2);\ - else\ - $$ = x2 -#define Pcolon(x) $$ = x -#define Pdco0(x1,x2,x3) $$ = invk_nd(x2,x1,list_nd(x2,EmptyNode)) -#define Pdco1(x1,x2,x3,x4) $$ = invk_nd(x2,x1,list_nd(x2,x3)) -#define Pdcolist0(x) $$ = tree3(N_Create,x,x);\ - proc_lst->has_coexpr = 1; -#define Pdcolist1(x1,x2,x3) $$ =tree4(N_Elist,x2,x1,tree3(N_Create,x2,x3));\ - proc_lst->has_coexpr = 1; -#define Proc1(x1,x2,x3,x4,x5,x6) $$ = tree6(N_Proc,x1,x1,x4,x5,x6) -#define Procbody1() $$ = EmptyNode -#define Procbody2(x1,x2,x3) $$ = tree4(N_Slist,x2,x1,x3) -#define Procdcl(x) proc_lst->tree = x -#define Prochead1(x1,x2) init_proc(Str0(x2));\ - idflag = F_Argument -#define Prochead2(x1,x2,x3,x4,x5,x6) /* empty */ -#define Progend(x1,x2) /* empty */ -#define Recdcl(x) /* empty */ -#define Record1(x1, x2) init_rec(Str0(x2));\ - idflag = F_Field -#define Record2(x1,x2,x3,x4,x5,x6) /* empty */ -#define Repeat(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) -#define Return(x1,x2) $$ = tree4(N_Ret,x1,x1,x2) -#define Rliter(x) CSym0(x) = putlit(Str0(x),F_RealLit,0) -#define Section(x1,x2,x3,x4,x5,x6) $$ = sect_nd(x4,x1,x3,x5) -#define Sliter(x) CSym0(x) = putlit(Str0(x),F_StrLit,(int)Val1(x)) -#define Static(x) idflag = F_Static -#define Subscript(x1,x2,x3,x4) $$ = buildarray(x1,x2,x3) -#define Suspend0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) -#define Suspend1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) -#define To0(x1,x2,x3) $$ = to_nd(x2,x1,x3) -#define To1(x1,x2,x3,x4,x5) $$ = toby_nd(x2,x1,x3,x5) -#define Uat(x1,x2) $$ = tree5(N_Activat,x1,x1,EmptyNode,x2) -#define Ubackslash(x1,x2) $$ = unary_nd(x1,x2) -#define Ubang(x1,x2) $$ = unary_nd(x1,x2) -#define Ubar(x1,x2) $$ = tree3(N_Bar,x2,x2) -#define Ucaret(x1,x2) $$ = unary_nd(x1,x2) -#define Uconcat(x1,x2) $$ = tree3(N_Bar,x2,x2) -#define Udiff(x1,x2) $$ = MultiUnary(x1,x2) -#define Udot(x1,x2) $$ = unary_nd(x1,x2) -#define Uequiv(x1,x2) $$ = MultiUnary(x1,x2) -#define Uinter(x1,x2) $$ = MultiUnary(x1,x2) -#define Ulconcat(x1,x2) $$ = tree3(N_Bar,x2,x2) -#define Ulexeq(x1,x2) $$ = MultiUnary(x1,x2) -#define Ulexne(x1,x2) $$ = MultiUnary(x1,x2) -#define Uminus(x1,x2) $$ = unary_nd(x1,x2) -#define Unot(x1,x2) $$ = tree3(N_Not,x2,x2) -#define Unotequiv(x1,x2) $$ = MultiUnary(x1,x2) -#define Until0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) -#define Until1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) -#define Unumeq(x1,x2) $$ = unary_nd(x1,x2) -#define Unumne(x1,x2) $$ = MultiUnary(x1,x2) -#define Uplus(x1,x2) $$ = unary_nd(x1,x2) -#define Uqmark(x1,x2) $$ = unary_nd(x1,x2) -#define Uslash(x1,x2) $$ = unary_nd(x1,x2) -#define Ustar(x1,x2) $$ = unary_nd(x1,x2) -#define Utilde(x1,x2) $$ = unary_nd(x1,x2) -#define Uunion(x1,x2) $$ = MultiUnary(x1,x2) -#define Var(x) LSym0(x) = putloc(Str0(x),0) -#define While0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) -#define While1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) -%} - -%% -#include "../h/grammar.h" -%% - -/* - * xfree(p) -- used with free(p) macro to avoid compiler errors from - * miscast free calls generated by Yacc. - */ -#undef free -static void xfree(p) -char *p; -{ - free(p); -} - -/*#define free(p) xfree((char*)p)*/ diff --git a/src/iconc/chkinv.c b/src/iconc/chkinv.c deleted file mode 100644 index af4298f..0000000 --- a/src/iconc/chkinv.c +++ /dev/null @@ -1,545 +0,0 @@ -/* - * chkinv.c - routines to determine which global names are only - * used as immediate operand to invocation and to directly invoke - * the corresponding operations. In addition, simple assignments to - * names variables are recognized and it is determined whether - * procedures return, suspend, or fail. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ctoken.h" -#include "cglobals.h" -#include "ccode.h" -#include "cproto.h" - -/* - * prototypes for static functions. - */ -static int chg_ret (int flag); -static void chksmpl (struct node *n, int smpl_invk); -static int seq_exec (int exec_flg1, int exec_flg2); -static int spcl_inv (struct node *n, struct node *asgn); - -static ret_flag; - -/* - * chkinv - check for invocation and assignment optimizations. - */ -void chkinv() - { - struct gentry *gp; - struct pentry *proc; - int exec_flg; - int i; - - if (debug_info) - return; /* The following analysis is not valid */ - - /* - * start off assuming that global variables for procedure, etc. are - * only used as immediate operands to invocations then mark any - * which are not. Any variables retaining the property are never - * changed. Go through the code and change invocations to such - * variables to invocations directly to the operation. - */ - for (i = 0; i < GHSize; i++) - for (gp = ghash[i]; gp != NULL; gp = gp->blink) { - if (gp->flag & (F_Proc | F_Builtin | F_Record) && - !(gp->flag & F_StrInv)) - gp->flag |= F_SmplInv; - /* - * However, only optimize normal cases for main. - */ - if (strcmp(gp->name, "main") == 0 && (gp->flag & F_Proc) && - (gp->val.proc->nargs < 0 || gp->val.proc->nargs > 1)) - gp->flag &= ~(uword)F_SmplInv; - /* - * Work-around to problem that a co-expression block needs - * block for enclosing procedure: just keep procedure in - * a variable to force outputting the block. Note, this - * inhibits tailored calling conventions for the procedure. - */ - if ((gp->flag & F_Proc) && gp->val.proc->has_coexpr) - gp->flag &= ~(uword)F_SmplInv; - } - - /* - * Analyze code in each procedure. - */ - for (proc = proc_lst; proc != NULL; proc = proc->next) { - chksmpl(Tree1(proc->tree), 0); /* initial expression */ - chksmpl(Tree2(proc->tree), 0); /* procedure body */ - } - - /* - * Go through each procedure performing "naive" optimizations on - * invocations and assignments. Also determine whether the procedure - * returns, suspends, or fails (possibly by falling through to - * the end). - */ - for (proc = proc_lst; proc != NULL; proc = proc->next) { - ret_flag = 0; - spcl_inv(Tree1(proc->tree), NULL); - exec_flg = spcl_inv(Tree2(proc->tree), NULL); - if (exec_flg & DoesFThru) - ret_flag |= DoesFail; - proc->ret_flag = ret_flag; - } - } - -/* - * smpl_invk - find any global variable uses that are not a simple - * invocation and mark the variables. - */ -static void chksmpl(n, smpl_invk) -struct node *n; -int smpl_invk; - { - struct node *cases; - struct node *clause; - struct lentry *var; - int i; - int lst_arg; - - switch (n->n_type) { - case N_Alt: - case N_Apply: - case N_Limit: - case N_Slist: - chksmpl(Tree0(n), 0); - chksmpl(Tree1(n), 0); - break; - - case N_Activat: - chksmpl(Tree1(n), 0); - chksmpl(Tree2(n), 0); - break; - - case N_Augop: - chksmpl(Tree2(n), 0); - chksmpl(Tree3(n), 0); - break; - - case N_Bar: - case N_Break: - case N_Create: - case N_Field: - case N_Not: - chksmpl(Tree0(n), 0); - break; - - case N_Case: - chksmpl(Tree0(n), 0); /* control clause */ - cases = Tree1(n); - while (cases != NULL) { - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - chksmpl(Tree0(clause), 0); /* value of clause */ - chksmpl(Tree1(clause), 0); /* body of clause */ - } - if (Tree2(n) != NULL) - chksmpl(Tree2(n), 0); /* default */ - break; - - case N_Cset: - case N_Int: - case N_Real: - case N_Str: - case N_Empty: - case N_Next: - break; - - case N_Id: - if (!smpl_invk) { - /* - * The variable is being used somewhere other than in a simple - * invocation. - */ - var = LSym0(n); - if (var->flag & F_Global) - var->val.global->flag &= ~F_SmplInv; - } - break; - - case N_If: - chksmpl(Tree0(n), 0); - chksmpl(Tree1(n), 0); - chksmpl(Tree2(n), 0); - break; - - case N_Invok: - lst_arg = 1 + Val0(n); - /* - * Check the thing being invoked, noting that it is in fact being - * invoked. - */ - chksmpl(Tree1(n), 1); - for (i = 2; i <= lst_arg; ++i) - chksmpl(n->n_field[i].n_ptr, 0); /* arg i - 1 */ - break; - - case N_InvOp: - lst_arg = 1 + Val0(n); - for (i = 2; i <= lst_arg; ++i) - chksmpl(n->n_field[i].n_ptr, 0); /* arg i */ - break; - - case N_Loop: { - switch ((int)Val0(Tree0(n))) { - case EVERY: - case SUSPEND: - case WHILE: - case UNTIL: - chksmpl(Tree1(n), 0); /* control clause */ - chksmpl(Tree2(n), 0); /* do clause */ - break; - - case REPEAT: - chksmpl(Tree1(n), 0); /* clause */ - break; - } - } - - case N_Ret: - if (Val0(Tree0(n)) == RETURN) - chksmpl(Tree1(n), 0); - break; - - case N_Scan: - chksmpl(Tree1(n), 0); - chksmpl(Tree2(n), 0); - break; - - case N_Sect: - chksmpl(Tree2(n), 0); - chksmpl(Tree3(n), 0); - chksmpl(Tree4(n), 0); - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - } - -/* - * spcl_inv - look for general invocations that can be replaced by - * special invocations. Simple assignment to a named variable is - * is a particularly special case. Also, determine whether execution - * might "fall through" this code and whether the code might fail. - */ -static int spcl_inv(n, asgn) -struct node *n; -struct node *asgn; /* the result goes into this special-cased assignment */ - { - struct node *cases; - struct node *clause; - struct node *invokee; - struct gentry *gvar; - struct loop { - int exec_flg; - struct node *asgn; - struct loop *prev; - } loop_info; - struct loop *loop_sav; - int exec_flg; - int i; - int lst_arg; - static struct loop *cur_loop = NULL; - - switch (n->n_type) { - case N_Activat: - if (asgn != NULL) - Val0(asgn) = AsgnDeref; /* assume worst case */ - return seq_exec(spcl_inv(Tree1(n), NULL), spcl_inv(Tree2(n), NULL)); - - case N_Alt: - exec_flg = spcl_inv(Tree0(n), asgn) & DoesFThru; - return exec_flg | spcl_inv(Tree1(n), asgn); - - case N_Apply: - if (asgn != NULL) - Val0(asgn) = AsgnCopy; /* assume worst case */ - return seq_exec(spcl_inv(Tree0(n), NULL), spcl_inv(Tree1(n), NULL)); - - case N_Augop: - exec_flg = chg_ret(Impl1(n)->ret_flag); - if (Tree2(n)->n_type == N_Id) { - /* - * This is an augmented assignment to a named variable. - * An optimized version of assignment can be used. - */ - n->n_type = N_SmplAug; - if (Impl1(n)->use_rslt) - Val0(n) = AsgnCopy; - else - Val0(n) = AsgnDirect; - } - else { - if (asgn != NULL) - Val0(asgn) = AsgnDeref; /* this operation produces a variable */ - exec_flg = seq_exec(exec_flg, spcl_inv(Tree2(n), NULL)); - exec_flg = seq_exec(exec_flg, chg_ret(Impl0(n)->ret_flag)); - } - return seq_exec(exec_flg, spcl_inv(Tree3(n), NULL)); - - case N_Bar: - return spcl_inv(Tree0(n), asgn); - - case N_Break: - if (cur_loop == NULL) { - nfatal(n, "invalid context for break", NULL); - return 0; - } - loop_sav = cur_loop; - cur_loop = cur_loop->prev; - loop_sav->exec_flg |= spcl_inv(Tree0(n), loop_sav->asgn); - cur_loop = loop_sav; - return 0; - - case N_Create: - spcl_inv(Tree0(n), NULL); - return DoesFThru; - - case N_Case: - exec_flg = spcl_inv(Tree0(n), NULL) & DoesFail; /* control clause */ - cases = Tree1(n); - while (cases != NULL) { - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - spcl_inv(Tree0(clause), NULL); - exec_flg |= spcl_inv(Tree1(clause), asgn); - } - if (Tree2(n) != NULL) - exec_flg |= spcl_inv(Tree2(n), asgn); /* default */ - else - exec_flg |= DoesFail; - return exec_flg; - - case N_Cset: - case N_Int: - case N_Real: - case N_Str: - case N_Empty: - return DoesFThru; - - case N_Field: - if (asgn != NULL) - Val0(asgn) = AsgnDeref; /* operation produces variable */ - return spcl_inv(Tree0(n), NULL); - - case N_Id: - if (asgn != NULL) - Val0(asgn) = AsgnDeref; /* variable */ - return DoesFThru; - - case N_If: - spcl_inv(Tree0(n), NULL); - exec_flg = spcl_inv(Tree1(n), asgn); - if (Tree2(n)->n_type == N_Empty) - exec_flg |= DoesFail; - else - exec_flg |= spcl_inv(Tree2(n), asgn); - return exec_flg; - - case N_Invok: - lst_arg = 1 + Val0(n); - invokee = Tree1(n); - exec_flg = DoesFThru; - for (i = 2; i <= lst_arg; ++i) - exec_flg = seq_exec(exec_flg, spcl_inv(n->n_field[i].n_ptr, NULL)); - if (invokee->n_type == N_Id && LSym0(invokee)->flag & F_Global) { - /* - * This is an invocation of a global variable. If we can - * convert this to a direct invocation, determine whether - * it is an invocation of a procedure, built-in function, - * or record constructor; each has a difference kind of - * direct invocation node. - */ - gvar = LSym0(invokee)->val.global; - if (gvar->flag & F_SmplInv) { - switch (gvar->flag & (F_Proc | F_Builtin | F_Record)) { - case F_Proc: - n->n_type = N_InvProc; - Proc1(n) = gvar->val.proc; - return DoesFThru | DoesFail; /* assume worst case */ - case F_Builtin: - n->n_type = N_InvOp; - Impl1(n) = gvar->val.builtin; - if (asgn != NULL && Impl1(n)->use_rslt) - Val0(asgn) = AsgnCopy; - return seq_exec(exec_flg, chg_ret( - gvar->val.builtin->ret_flag)); - case F_Record: - n->n_type = N_InvRec; - Rec1(n) = gvar->val.rec; - return seq_exec(exec_flg, DoesFThru | - (err_conv ? DoesFail : 0)); - } - } - } - if (asgn != NULL) - Val0(asgn) = AsgnCopy; /* assume worst case */ - spcl_inv(invokee, NULL); - return DoesFThru | DoesFail; /* assume worst case */ - - case N_InvOp: - if (Impl1(n)->op != NULL && strcmp(Impl1(n)->op, ":=") == 0 && - Tree2(n)->n_type == N_Id) { - /* - * This is a simple assignment to a named variable. - * An optimized version of assignment can be used. - */ - n->n_type = N_SmplAsgn; - - /* - * For now, assume rhs of := can compute directly into a - * variable. This may be changed when the rhs is examined - * in the recursive call to spcl_inv(). - */ - Val0(n) = AsgnDirect; - return spcl_inv(Tree3(n), n); - } - else { - /* - * No special cases. - */ - lst_arg = 1 + Val0(n); - exec_flg = chg_ret(Impl1(n)->ret_flag); - for (i = 2; i <= lst_arg; ++i) - exec_flg = seq_exec(exec_flg, spcl_inv(n->n_field[i].n_ptr, - NULL)); /* arg i */ - if (asgn != NULL && Impl1(n)->use_rslt) - Val0(asgn) = AsgnCopy; - return exec_flg; - } - - case N_Limit: - return seq_exec(spcl_inv(Tree0(n), asgn), - spcl_inv(Tree1(n), NULL)) | DoesFail; - - case N_Loop: { - loop_info.prev = cur_loop; - loop_info.exec_flg = 0; - loop_info.asgn = asgn; - cur_loop = &loop_info; - switch ((int)Val0(Tree0(n))) { - case EVERY: - case WHILE: - case UNTIL: - spcl_inv(Tree1(n), NULL); /* control clause */ - spcl_inv(Tree2(n), NULL); /* do clause */ - exec_flg = DoesFail; - break; - - case SUSPEND: - spcl_inv(Tree1(n), NULL); /* control clause */ - spcl_inv(Tree2(n), NULL); /* do clause */ - ret_flag |= DoesSusp; - exec_flg = DoesFail; - break; - - case REPEAT: - spcl_inv(Tree1(n), NULL); /* clause */ - exec_flg = 0; - break; - } - exec_flg |= cur_loop->exec_flg; - cur_loop = cur_loop->prev; - return exec_flg; - } - - case N_Next: - return 0; - - case N_Not: - exec_flg = spcl_inv(Tree0(n), NULL); - return ((exec_flg & DoesFail) ? DoesFThru : 0) | - ((exec_flg & DoesFThru) ? DoesFail: 0); - - case N_Ret: - if (Val0(Tree0(n)) == RETURN) { - exec_flg = spcl_inv(Tree1(n), NULL); - ret_flag |= DoesRet; - if (exec_flg & DoesFail) - ret_flag |= DoesFail; - } - else - ret_flag |= DoesFail; - return 0; - - case N_Scan: - if (asgn != NULL) - Val0(asgn) = AsgnCopy; /* assume worst case */ - return seq_exec(spcl_inv(Tree1(n), NULL), - spcl_inv(Tree2(n), NULL)); - - case N_Sect: - if (asgn != NULL && Impl0(n)->use_rslt) - Val0(asgn) = AsgnCopy; - exec_flg = spcl_inv(Tree2(n), NULL); - exec_flg = seq_exec(exec_flg, spcl_inv(Tree3(n), NULL)); - exec_flg = seq_exec(exec_flg, spcl_inv(Tree4(n), NULL)); - return seq_exec(exec_flg, chg_ret(Impl0(n)->ret_flag)); - - case N_Slist: - exec_flg = spcl_inv(Tree0(n), NULL); - if (exec_flg & (DoesFThru | DoesFail)) - exec_flg = DoesFThru; - return seq_exec(exec_flg, spcl_inv(Tree1(n), asgn)); - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - /* NOTREACHED */ - } - } - -/* - * seq_exec - take the execution flags for sequential pieces of code - * and compute the flags for the combined code. - */ -static int seq_exec(exec_flg1, exec_flg2) -int exec_flg1; -int exec_flg2; - { - return (exec_flg1 & exec_flg2 & DoesFThru) | - ((exec_flg1 | exec_flg2) & DoesFail); - } - -/* - * chg_ret - take a return flag and change suspend and return to - * "fall through". If error conversion is supported, change error - * failure to failure. - * - */ -static int chg_ret(flag) -int flag; - { - int flg1; - - flg1 = flag & DoesFail; - if (flag & (DoesRet | DoesSusp)) - flg1 |= DoesFThru; - if (err_conv && (flag & DoesEFail)) - flg1 |= DoesFail; - return flg1; - } - - diff --git a/src/iconc/clex.c b/src/iconc/clex.c deleted file mode 100644 index 8e7d657..0000000 --- a/src/iconc/clex.c +++ /dev/null @@ -1,18 +0,0 @@ -/* - * clex.c -- the lexical analyzer for iconc. - */ -#define Iconc - -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "ctoken.h" -#include "ctree.h" -#include "csym.h" -#include "ccode.h" -#include "cproto.h" - -#include "../h/parserr.h" -#include "../common/lextab.h" -#include "../common/yylex.h" -#include "../common/error.h" diff --git a/src/iconc/cmain.c b/src/iconc/cmain.c deleted file mode 100644 index 6daf5c4..0000000 --- a/src/iconc/cmain.c +++ /dev/null @@ -1,424 +0,0 @@ -/* - * cmain.c - main program icon compiler. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "ctree.h" -#include "ccode.h" -#include "csym.h" -#include "cproto.h" - -/* - * Prototypes. - */ -static void execute (char *ofile, char **args); -static FILE *open_out (char *fname); -static void rmfile (char *fname); -static void report (char *s); -static void usage (void); - -char *refpath; - -char patchpath[MaxPath+18] = "%PatchStringHere->"; - -/* - * Define global variables. - */ - -#define Global -#define Init(v) = v -#include "cglobals.h" - -/* - * getopt() variables - */ -extern int optind; /* index into parent argv vector */ -extern int optopt; /* character checked for validity */ -extern char *optarg; /* argument associated with option */ - -/* - * main program - */ -int main(argc,argv) -int argc; -char **argv; - { - int no_c_comp = 0; /* suppress C compile and link? */ - int errors = 0; /* compilation errors */ - char *cfile = NULL; /* name of C file - primary */ - char *hfile = NULL; /* name of C file - include */ - char *ofile = NULL; /* name of executable result */ - - char *db_name = "rt.db"; /* data base name */ - char *incl_file = "rt.h"; /* header file name */ - - char *db_path; /* path to data base */ - char *db_lst; /* list of private data bases */ - char *incl_path; /* path to header file */ - char *s, c1; - char buf[MaxPath]; /* file name construction buffer */ - int c; - int ret_code; - struct fileparts *fp; - - if ((int)strlen(patchpath) > 18) - refpath = patchpath+18; - else - refpath = relfile(argv[0], "/../"); - - /* - * Process options. - */ - while ((c = getopt(argc,argv,"+C:ELS:Tcf:mn:o:p:r:stuv:x")) != EOF) - switch (c) { - case 'C': /* -C C-comp: C compiler*/ - c_comp = optarg; - break; - case 'E': /* -E: preprocess only */ - pponly = 1; - no_c_comp = 1; - break; - case 'L': /* Ignore: interpreter only */ - break; - case 'S': /* Ignore: interpreter only */ - break; - case 'T': - just_type_trace = 1; - break; - case 'c': /* -c: produce C file only */ - no_c_comp = 1; - break; - case 'f': /* -f: enable features */ - for (s = optarg; *s != '\0'; ++s) { - switch (*s) { - case 'a': /* -fa: enable all features */ - line_info = 1; - debug_info = 1; - err_conv = 1; - largeints = 1; - str_inv = 1; - break; - case 'd': /* -fd: enable debugging features */ - line_info = 1; - debug_info = 1; - break; - case 'e': /* -fe: enable error conversion */ - err_conv = 1; - break; - case 'l': /* -fl: support large integers */ - largeints = 1; - break; - case 'n': /* -fn: enable line numbers */ - line_info = 1; - break; - case 's': /* -fs: enable full string invocation */ - str_inv = 1; - break; - default: - quitf("-f option must be a, d, e, l, n, or s. found: %s", - optarg); - } - } - break; - case 'm': /* -m: preprocess using m4(1) */ - m4pre = 1; - break; - case 'n': /* -n: disable optimizations */ - for (s = optarg; *s != '\0'; ++s) { - switch (*s) { - case 'a': /* -na: disable all optimizations */ - opt_cntrl = 0; - allow_inline = 0; - opt_sgnl = 0; - do_typinfer = 0; - break; - case 'c': /* -nc: disable control flow opts */ - opt_cntrl = 0; - break; - case 'e': /* -ne: disable expanding in-line */ - allow_inline = 0; - break; - case 's': /* -ns: disable switch optimizations */ - opt_sgnl = 0; - break; - case 't': /* -nt: disable type inference */ - do_typinfer = 0; - break; - default: - usage(); - } - } - break; - case 'o': /* -o file: name output file */ - ofile = optarg; - break; - case 'p': /* -p C-opts: options for C comp */ - if (*optarg == '\0') /* if empty string, clear options */ - c_opts = optarg; - else { /* else append to current set */ - s = (char *)alloc(strlen(c_opts) + 1 + strlen(optarg) + 1); - sprintf(s, "%s %s", c_opts, optarg); - c_opts = s; - } - break; - case 'r': /* -r path: primary runtime system */ - refpath = optarg; - break; - case 's': /* -s: suppress informative messages */ - verbose = 0; - break; - case 't': /* -t: &trace = -1 */ - line_info = 1; - debug_info = 1; - trace = 1; - break; - case 'u': /* -u: warn about undeclared ids */ - uwarn = 1; - break; - case 'v': /* -v: set level of verbosity */ - if (sscanf(optarg, "%d%c", &verbose, &c1) != 1) - quitf("bad operand to -v option: %s",optarg); - break; - default: - case 'x': /* -x illegal until after file list */ - usage(); - } - - init(); /* initialize memory for translation */ - - /* - * Load the data bases of information about run-time routines and - * determine what libraries are needed for linking (these libraries - * go before any specified on the command line). - */ - db_lst = getenv("DBLIST"); - if (db_lst != NULL) - db_lst = salloc(db_lst); - s = db_lst; - while (s != NULL) { - db_lst = s; - while (isspace(*db_lst)) - ++db_lst; - if (*db_lst == '\0') - break; - for (s = db_lst; !isspace(*s) && *s != '\0'; ++s) - ; - if (*s == '\0') - s = NULL; - else - *s++ = '\0'; - readdb(db_lst); - addlib(salloc(makename(buf,SourceDir, db_lst, LibSuffix))); - } - db_path = (char *)alloc((unsigned int)strlen(refpath) + strlen(db_name) + 1); - strcpy(db_path, refpath); - strcat(db_path, db_name); - readdb(db_path); - addlib(salloc(makename(buf,SourceDir, db_path, LibSuffix))); - - /* - * Scan the rest of the command line for file name arguments. - */ - while (optind < argc) { - if (strcmp(argv[optind],"-x") == 0) /* stop at -x */ - break; - else if (strcmp(argv[optind],"-") == 0) - src_file("-"); /* "-" means standard input */ - else if (argv[optind][0] == '-') - addlib(argv[optind]); /* assume linker option */ - else { - fp = fparse(argv[optind]); /* parse file name */ - if (*fp->ext == '\0' || smatch(fp->ext, SourceSuffix)) { - makename(buf,SourceDir,argv[optind], SourceSuffix); - src_file(buf); - } - else - /* - * Assume all files that are not Icon source go to linker. - */ - addlib(argv[optind]); - } - optind++; - } - - if (srclst == NULL) - usage(); /* error -- no files named */ - - if (pponly) { - if (trans() == 0) - exit (EXIT_FAILURE); - else - exit (EXIT_SUCCESS); - } - - if (ofile == NULL) { /* if no -o file, synthesize a name */ - if (strcmp(srclst->name,"-") == 0) - ofile = salloc(makename(buf,TargetDir,"stdin",ExecSuffix)); - else - ofile = salloc(makename(buf,TargetDir,srclst->name,ExecSuffix)); - } else { /* add extension if necessary */ - fp = fparse(ofile); - if (*fp->ext == '\0' && *ExecSuffix != '\0') - ofile = salloc(makename(buf,NULL,ofile,ExecSuffix)); - } - - /* - * Make name of intermediate C files. - */ - cfile = salloc(makename(buf,TargetDir,ofile,CSuffix)); - hfile = salloc(makename(buf,TargetDir,ofile,HSuffix)); - - codefile = open_out(cfile); - fprintf(codefile, "#include \"%s\"\n", hfile); - - inclfile = open_out(hfile); - fprintf(inclfile, "#define COMPILER 1\n"); - - incl_path = (char *)alloc((unsigned int)(strlen(refpath) + - strlen(incl_file) + 1)); - strcpy(incl_path, refpath); - strcat(incl_path, incl_file); - fprintf(inclfile,"#include \"%s\"\n", incl_path); - - /* - * Translate .icn files to make C file. - */ - if ((verbose > 0) && !just_type_trace) - report("Translating to C"); - - errors = trans(); - if ((errors > 0) || just_type_trace) { /* exit if errors seen */ - rmfile(cfile); - rmfile(hfile); - if (errors > 0) - exit(EXIT_FAILURE); - else exit(EXIT_SUCCESS); - } - - fclose(codefile); - fclose(inclfile); - - /* - * Compile and link C file. - */ - if (no_c_comp) /* exit if no C compile wanted */ - exit(EXIT_SUCCESS); - - if (verbose > 0) - report("Compiling and linking C code"); - - ret_code = ccomp(cfile, ofile); - if (ret_code == EXIT_FAILURE) { - fprintf(stderr, "*** C compile and link failed ***\n"); - rmfile(ofile); - } - - /* - * Finish by removing C files. - */ - rmfile(cfile); - rmfile(hfile); - rmfile(makename(buf,TargetDir,cfile,ObjSuffix)); - - if (ret_code == EXIT_SUCCESS && optind < argc) { - if (verbose > 0) - report("Executing"); - execute (ofile, argv+optind+1); - } - - return ret_code; - } - -/* - * execute - execute compiled Icon program - */ -static void execute(ofile,args) -char *ofile, **args; - { - - int n; - char **argv, **p; - char buf[MaxPath]; /* file name construction buffer */ - - ofile = salloc(makename(buf,"./",ofile,ExecSuffix)); - - for (n = 0; args[n] != NULL; n++) /* count arguments */ - ; - p = argv = (char **)alloc((unsigned int)((n + 2) * sizeof(char *))); - - *p++ = ofile; /* set executable file */ - - while (*p++ = *args++) /* copy args into argument vector */ - ; - *p = NULL; - - execvp(ofile,argv); - quitf("could not run %s",ofile); - } - -/* - * Report phase. - */ -static void report(s) -char *s; - { - fprintf(stderr,"%s:\n",s); - } - -/* - * rmfile - remove a file - */ - -static void rmfile(fname) -char *fname; - { - remove(fname); - } - -/* - * open_out - open a C output file and write identifying information - * to the front. - */ -static FILE *open_out(fname) -char *fname; - { - FILE *f; - static char *ident = "/*ICONC*/"; - int c; - int i; - - /* - * If the file already exists, make sure it is old output from iconc - * before overwriting it. Note, this test doesn't work if the file - * is writable but not readable. - */ - f = fopen(fname, "r"); - if (f != NULL) { - for (i = 0; i < (int)strlen(ident); ++i) { - c = getc(f); - if (c == EOF) - break; - if ((char)c != ident[i]) - quitf("%s not in iconc format; rename or delete, and rerun", fname); - } - fclose(f); - } - - f = fopen(fname, "w"); - if (f == NULL) - quitf("cannot create %s", fname); - fprintf(f, "%s\n", ident); /* write "belongs to iconc" comment */ - id_comment(f); /* write detailed comment for human readers */ - fflush(f); - return f; - } - -/* - * Print an error message if called incorrectly. The message depends - * on the legal options for this system. - */ -static void usage() - { - fprintf(stderr,"usage: %s %s file ... [-x args]\n", progname, CUsage); - exit(EXIT_FAILURE); - } diff --git a/src/iconc/cmem.c b/src/iconc/cmem.c deleted file mode 100644 index 720a495..0000000 --- a/src/iconc/cmem.c +++ /dev/null @@ -1,114 +0,0 @@ -/* - * cmem.c -- memory initialization and allocation for the translator. - */ -#include "../h/gsupport.h" -#include "cglobals.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ccode.h" -#include "cproto.h" - -struct centry *chash[CHSize]; /* hash area for constant table */ -struct fentry *fhash[FHSize]; /* hash area for field table */ -struct gentry *ghash[GHSize]; /* hash area for global table */ - -struct implement *bhash[IHSize]; /* hash area for built-in functions */ -struct implement *khash[IHSize]; /* hash area for keywords */ -struct implement *ohash[IHSize]; /* hash area for operators */ - -struct implement *spec_op[NumSpecOp]; /* table of ops with special syntax */ - -char pre[PrfxSz] = {'0', '0', '0'}; /* initial function name prefix */ - -extern struct str_buf lex_sbuf; - - -/* - * init - initialize memory for the translator - */ - -void init() -{ - int i; - - init_str(); - init_sbuf(&lex_sbuf); - - /* - * Zero out the hash tables. - */ - for (i = 0; i < CHSize; i++) - chash[i] = NULL; - for (i = 0; i < FHSize; i++) - fhash[i] = NULL; - for (i = 0; i < GHSize; i++) - ghash[i] = NULL; - for (i = 0; i < IHSize; i++) { - bhash[i] = NULL; - khash[i] = NULL; - ohash[i] = NULL; - } - - /* - * Clear table of operators with non-standard operator syntax. - */ - for (i = 0; i < NumSpecOp; ++i) - spec_op[i] = NULL; - } - -/* - * init_proc - add a new entry on front of procedure list. - */ -void init_proc(name) -char *name; - { - register struct pentry *p; - int i; - struct gentry *sym_ent; - - p = NewStruct(pentry); - p->name = name; - nxt_pre(p->prefix, pre, PrfxSz); - p->prefix[PrfxSz] = '\0'; - p->nargs = 0; - p->args = NULL; - p->ndynam = 0; - p->dynams = NULL; - p->nstatic = 0; - p->has_coexpr = 0; - p->statics = NULL; - p->ret_flag = DoesRet | DoesFail | DoesSusp; /* start out pessimistic */ - p->arg_lst = 0; - p->lhash = - (struct lentry **)alloc((unsigned int)((LHSize)*sizeof(struct lentry *))); - for (i = 0; i < LHSize; i++) - p->lhash[i] = NULL; - p->next = proc_lst; - proc_lst = p; - sym_ent = instl_p(name, F_Proc); - sym_ent->val.proc = proc_lst; - } - -/* - * init_rec - add a new entry on the front of the record list. - */ -void init_rec(name) -char *name; - { - register struct rentry *r; - struct gentry *sym_ent; - static int rec_num = 0; - - r = NewStruct(rentry); - r->name = name; - nxt_pre(r->prefix, pre, PrfxSz); - r->prefix[PrfxSz] = '\0'; - r->rec_num = rec_num++; - r->nfields = 0; - r->fields = NULL; - r->next = rec_lst; - rec_lst = r; - sym_ent= instl_p(name, F_Record); - sym_ent->val.rec = r; - } diff --git a/src/iconc/codegen.c b/src/iconc/codegen.c deleted file mode 100644 index 8ca5bd1..0000000 --- a/src/iconc/codegen.c +++ /dev/null @@ -1,1918 +0,0 @@ -/* - * codegen.c - routines to write out C code. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "cglobals.h" -#include "csym.h" -#include "ccode.h" -#include "ctree.h" -#include "cproto.h" - -#ifndef LoopThreshold -#define LoopThreshold 7 -#endif /* LoopThreshold */ - -/* - * MinOne - arrays sizes must be at least 1. - */ -#define MinOne(n) ((n) > 0 ? (n) : 1) - -/* - * ChkSeqNum - make sure a label has been given a sequence number. - */ -#define ChkSeqNum(x) if ((x)->SeqNum == 0) (x)->SeqNum = ++lbl_seq_num - -/* - * ChkBound - for a given procedure, signals that transfer control to a - * bounding label all use the same signal number. - */ -#define ChkBound(x) (((x)->LabFlg & Bounding) ? bound_sig : (x)) - -/* - * When a switch statement for signal handling is optimized, there - * are three possible forms of default clauses. - */ -#define DfltNone 0 /* no default clause */ -#define DfltBrk 1 /* default is just a break */ -#define DfltRetSig 2 /* default is to return the signal from the call */ - -/* - * Prototypes for static functions. - */ -static int arg_nms (struct lentry *lptr, int prt); -static void bi_proc (char *name, struct implement *ip); -static void chkforgn (int outer); -static int dyn_nms (struct lentry *lptr, int prt); -static void fldnames (struct fldname *fields); -static void fnc_blk (struct gentry *gptr); -static void frame (int outer); -static void good_clsg (struct code *call, int outer); -static void initpblk (FILE *f, int c, char *prefix, char *name, - int nquals, int nparam, int ndynam, int nstatic, - int frststat); -static char *is_builtin (struct gentry *gptr); -static void proc_blk (struct gentry *gptr, int init_glbl); -static void prt_ary (struct code *cd, int outer); -static void prt_cond (struct code *cond); -static void prt_cont (struct c_fnc *cont); -static void prt_var (struct lentry *var, int outer); -static void prtcall (struct code *call, int outer); -static void prtcode (struct code *cd, int outer); -static void prtpccall (int outer); -static void rec_blk (struct gentry *gptr, int init_glbl); -static void smpl_clsg (struct code *call, int outer); -static void stat_nms (struct lentry *lptr, int prt); -static void val_loc (struct val_loc *rslt, int outer); - -static int n_stat = -1; /* number of static variables */ - -/* - * var_dcls - produce declarations necessary to implement variables - * and to initialize globals and statics: procedure blocks, procedure - * frames, record blocks, declarations for globals and statics, the - * C main program. - */ -void var_dcls() - { - register int i; - register struct gentry *gptr; - struct gentry *gbl_main; - struct pentry *prc_main; - int n_glob = 0; - int flag; - int init_glbl; - int first; - char *pfx; - - /* - * Output initialized array of descriptors for globals. - */ - fprintf(codefile, "\nstatic struct {word dword; union block *vword;}"); - fprintf(codefile, " init_globals[NGlobals] = {\n"); - prc_main = NULL; - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { - flag = gptr->flag & ~(F_Global | F_StrInv); - if (strcmp(gptr->name, "main") == 0 && (gptr->flag & F_Proc)) { - /* - * Remember main procedure. - */ - gbl_main = gptr; - prc_main = gbl_main->val.proc; - } - if (flag == 0) { - /* - * Ordinary variable. - */ - gptr->index = n_glob++; - fprintf(codefile, " {D_Null},\n"); - } - else { - /* - * Procedure, function, or record constructor. If the variable - * has not been optimized away, initialize the it to reference - * the procedure block. - */ - if (flag & F_SmplInv) { - init_glbl = 0; - flag &= ~(uword)F_SmplInv; - } - else { - init_glbl = 1; - gptr->index = n_glob++; - fprintf(codefile, " {D_Proc, "); - } - switch (flag) { - case F_Proc: - proc_blk(gptr, init_glbl); - break; - case F_Builtin: - if (init_glbl) - fnc_blk(gptr); - break; - case F_Record: - rec_blk(gptr, init_glbl); - } - } - } - if (n_glob == 0) - fprintf(codefile, " {D_Null} /* place holder */\n"); - fprintf(codefile, " };\n"); - - if (prc_main == NULL) { - nfatal(NULL, "main procedure missing", NULL); - return; - } - - /* - * Output array of descriptors initialized to the names of the - * global variables that have not been optimized away. - */ - if (n_glob == 0) - fprintf(codefile, "\nstruct sdescrip init_gnames[1];\n"); - else { - fprintf(codefile, "\nstruct sdescrip init_gnames[NGlobals] = {\n"); - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) - if (!(gptr->flag & F_SmplInv)) - fprintf(codefile, " {%d, \"%s\"},\n", strlen(gptr->name), - gptr->name); - fprintf(codefile, " };\n"); - } - - /* - * Output array of pointers to builtin functions that correspond to - * names of the global variables. - */ - if (n_glob == 0) - fprintf(codefile, "\nstruct b_proc *builtins[1];\n"); - else { - fprintf(codefile, "\nstruct b_proc *builtins[NGlobals] = {\n"); - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) - if (!(gptr->flag & F_SmplInv)) { - /* - * Need to output *something* to stay in step with other arrays. - */ - if (pfx = is_builtin(gptr)) { - fprintf(codefile, " (struct b_proc *)&BF%c%c_%s,\n", - pfx[0], pfx[1], gptr->name); - } - else - fprintf(codefile, " 0,\n"); - } - fprintf(codefile, " };\n"); - } - - /* - * Output C main function that initializes the run-time system and - * calls the main procedure. - */ - fprintf(codefile, "\n"); - fprintf(codefile, "int main(argc, argv)\n"); - fprintf(codefile, "int argc;\n"); - fprintf(codefile, "char **argv;\n"); - fprintf(codefile, " {\n"); - - /* - * If the main procedure requires a command-line argument list, we - * need a place to construct the Icon argument list. - */ - if (prc_main->nargs != 0 || !(gbl_main->flag & F_SmplInv)) { - fprintf(codefile, " struct {\n"); - fprintf(codefile, " struct tend_desc *previous;\n"); - fprintf(codefile, " int num;\n"); - fprintf(codefile, " struct descrip arg_lst;\n"); - fprintf(codefile, " } t;\n"); - fprintf(codefile, "\n"); - } - - /* - * Produce code to initialize run-time system variables. Some depend - * on compiler options. - */ - fprintf(codefile, " op_tbl = (struct b_proc *)init_op_tbl;\n"); - fprintf(codefile, " globals = (dptr)init_globals;\n"); - fprintf(codefile, " eglobals = &globals[%d];\n", n_glob); - fprintf(codefile, " gnames = (dptr)init_gnames;\n"); - fprintf(codefile, " egnames = &gnames[%d];\n", n_glob); - fprintf(codefile, " estatics = &statics[%d];\n", n_stat + 1); - if (debug_info) - fprintf(codefile, " debug_info = 1;\n"); - else - fprintf(codefile, " debug_info = 0;\n"); - if (line_info) { - fprintf(codefile, " line_info = 1;\n"); - fprintf(codefile, " file_name = \"\";\n"); - fprintf(codefile, " line_num = 0;\n"); - } - else - fprintf(codefile, " line_info = 0;\n"); - if (err_conv) - fprintf(codefile, " err_conv = 1;\n"); - else - fprintf(codefile, " err_conv = 0;\n"); - if (largeints) - fprintf(codefile, " largeints = 1;\n"); - else - fprintf(codefile, " largeints = 0;\n"); - - /* - * Produce code to call the routine to initialize the runtime system. - */ - if (trace) - fprintf(codefile, " init(*argv, &argc, argv, -1);\n"); - else - fprintf(codefile, " init(*argv, &argc, argv, 0);\n"); - fprintf(codefile, "\n"); - - /* - * If the main procedure requires an argument list (perhaps because - * it uses standard, rather than tailored calling conventions), - * set up the argument list. - */ - if (prc_main->nargs != 0 || !(gbl_main->flag & F_SmplInv)) { - fprintf(codefile, " t.arg_lst = nulldesc;\n"); - fprintf(codefile, " t.num = 1;\n"); - fprintf(codefile, " t.previous = NULL;\n"); - fprintf(codefile, " tend = (struct tend_desc *)&t;\n"); - if (prc_main->nargs == 0) - fprintf(codefile, - " /* main() takes no arguments: construct no list */\n"); - else - fprintf(codefile, " cmd_line(argc, argv, &t.arg_lst);\n"); - fprintf(codefile, "\n"); - } - else - fprintf(codefile, " tend = NULL;\n"); - - if (gbl_main->flag & F_SmplInv) { - /* - * procedure main only has a simplified implementation if it - * takes either 0 or 1 argument. - */ - first = 1; - if (prc_main->nargs == 0) - fprintf(codefile, " P%s_main(", prc_main->prefix); - else { - fprintf(codefile, " P%s_main(&t.arg_lst", prc_main->prefix); - first = 0; - } - if (prc_main->ret_flag & (DoesRet | DoesSusp)) { - if (!first) - fprintf(codefile, ", "); - fprintf(codefile, "&trashcan"); - first = 0; - } - if (prc_main->ret_flag & DoesSusp) - fprintf(codefile, ", (continuation)NULL"); - fprintf(codefile, ");\n"); - } - else /* the main procedure uses standard calling conventions */ - fprintf(codefile, - " P%s_main(1, &t.arg_lst, &trashcan, (continuation)NULL);\n", - prc_main->prefix); - fprintf(codefile, " \n"); - fprintf(codefile, " c_exit(EXIT_SUCCESS);\n"); - fprintf(codefile, " }\n"); - - /* - * Output to header file definitions related to global and static - * variables. - */ - fprintf(inclfile, "\n"); - if (n_glob == 0) { - fprintf(inclfile, "#define NGlobals 1\n"); - fprintf(inclfile, "int n_globals = 0;\n"); - } - else { - fprintf(inclfile, "#define NGlobals %d\n", n_glob); - fprintf(inclfile, "int n_globals = NGlobals;\n"); - } - ++n_stat; - fprintf(inclfile, "\n"); - fprintf(inclfile, "int n_statics = %d;\n", n_stat); - fprintf(inclfile, "struct descrip statics[%d]", MinOne(n_stat)); - if (n_stat > 0) { - fprintf(inclfile, " = {\n"); - for (i = 0; i < n_stat; ++i) - fprintf(inclfile, " {D_Null},\n"); - fprintf(inclfile, " };\n"); - } - else - fprintf(inclfile, ";\n"); - } - -/* - * proc_blk - create procedure block and initialize global variable, also - * compute offsets for local procedure variables. - */ -static void proc_blk(gptr, init_glbl) -struct gentry *gptr; -int init_glbl; - { - struct pentry *p; - register char *name; - int nquals; - - name = gptr->name; - p = gptr->val.proc; - - /* - * If we don't initialize a global variable for this procedure, we - * need only compute offsets for variables. - */ - if (init_glbl) { - fprintf(codefile, "(union block *)&BP%s_%s},\n", p->prefix, name); - nquals = 1 + Abs(p->nargs) + p->ndynam + p->nstatic; - fprintf(inclfile, "\n"); - fprintf(inclfile, "static int P%s_%s (int r_nargs, dptr r_args,", - p->prefix, name); - fprintf(inclfile, "dptr r_rslt, continuation r_s_cont);\n"); - initpblk(inclfile, 'P', p->prefix, name, nquals, p->nargs, p->ndynam, - p->nstatic, n_stat + 1); - fprintf(inclfile, "\n {%d, \"%s\"},\n", strlen(name), name); - } - arg_nms(p->args, init_glbl); - p->tnd_loc = dyn_nms(p->dynams, init_glbl); - stat_nms(p->statics, init_glbl); - if (init_glbl) - fprintf(inclfile, " }};\n"); - } - -/* - * arg_nms - compute offsets of arguments and, if needed, output the - * initializer for a descriptor for the argument name. - */ -static int arg_nms(lptr, prt) -struct lentry *lptr; -int prt; - { - register int n; - - if (lptr == NULL) - return 0; - n = arg_nms(lptr->next, prt); - lptr->val.index = n; - if (prt) - fprintf(inclfile, " {%d, \"%s\"},\n", strlen(lptr->name), lptr->name); - return n + 1; - } - -/* - * dyn_nms - compute offsets of dynamic locals and, if needed, output the - * initializer for a descriptor for the variable name. - */ -static int dyn_nms(lptr, prt) -struct lentry *lptr; -int prt; - { - register int n; - - if (lptr == NULL) - return 0; - n = dyn_nms(lptr->next, prt); - lptr->val.index = n; - if (prt) - fprintf(inclfile, " {%d, \"%s\"},\n", strlen(lptr->name), lptr->name); - return n + 1; - } - -/* - * stat_nams - compute offsets of static locals and, if needed, output the - * initializer for a descriptor for the variable name. - */ -static void stat_nms(lptr, prt) -struct lentry *lptr; -int prt; - { - if (lptr == NULL) - return; - stat_nms(lptr->next, prt); - lptr->val.index = ++n_stat; - if (prt) - fprintf(inclfile, " {%d, \"%s\"},\n", strlen(lptr->name), lptr->name); - } - -/* - * is_builtin - check if a global names or hides a builtin, returning prefix. - * If it hides one, we must also generate the prototype and block here. - */ -static char *is_builtin(gptr) -struct gentry *gptr; - { - struct implement *iptr; - - if (!(gptr->flag & F_StrInv)) /* if not eligible for string invoc */ - return 0; - if (gptr->flag & F_Builtin) /* if global *is* a builtin */ - return gptr->val.builtin->prefix; - iptr = db_ilkup(gptr->name, bhash); - if (iptr == NULL) /* if no builtin by this name */ - return NULL; - bi_proc(gptr->name, iptr); /* output prototype and proc block */ - return iptr->prefix; - } - -/* - * fnc_blk - output vword of descriptor for a built-in function and its - * procedure block. - */ -static void fnc_blk(gptr) -struct gentry *gptr; - { - struct implement *iptr; - char *name, *pfx; - - name = gptr->name; - iptr = gptr->val.builtin; - pfx = iptr->prefix; - /* - * output prototype and procedure block to inclfile. - */ - bi_proc(name, iptr); - /* - * vword of descriptor references the procedure block. - */ - fprintf(codefile, "(union block *)&BF%c%c_%s}, \n", pfx[0], pfx[1], name); - } - -/* - * bi_proc - output prototype and procedure block for builtin function. - */ -static void bi_proc(name, ip) -char *name; - struct implement *ip; - { - int nargs; - char prefix[3]; - - prefix[0] = ip->prefix[0]; - prefix[1] = ip->prefix[1]; - prefix[2] = '\0'; - nargs = ip->nargs; - if (nargs > 0 && ip->arg_flgs[nargs - 1] & VarPrm) - nargs = -nargs; - fprintf(inclfile, "\n"); - implproto(ip); - initpblk(inclfile, 'F', prefix, name, 1, nargs, -1, 0, 0); - fprintf(inclfile, "{%d, \"%s\"}}};\n", strlen(name), name); - } - -/* - * rec_blk - if needed, output vword of descriptor for a record - * constructor and output its procedure block. - */ -static void rec_blk(gptr, init_glbl) -struct gentry *gptr; -int init_glbl; - { - struct rentry *r; - register char *name; - int nfields; - - name = gptr->name; - r = gptr->val.rec; - nfields = r->nfields; - - /* - * If the variable is not optimized away, output vword of descriptor. - */ - if (init_glbl) - fprintf(codefile, "(union block *)&BR%s_%s},\n", r->prefix, name); - - fprintf(inclfile, "\n"); - /* - * Prototype for C function implementing constructor. If no optimizations - * have been performed on the variable, the standard calling conventions - * are used and we need a continuation parameter. - */ - fprintf(inclfile, - "static int R%s_%s (int r_nargs, dptr r_args, dptr r_rslt", - r->prefix, name); - if (init_glbl) - fprintf(inclfile, ", continuation r_s_cont"); - fprintf(inclfile, ");\n"); - - /* - * Procedure block, including record name and field names. - */ - initpblk(inclfile, 'R', r->prefix, name, nfields + 1, nfields, -2, - r->rec_num, 1); - fprintf(inclfile, "\n {%d, \"%s\"},\n", strlen(name), name); - fldnames(r->fields); - fprintf(inclfile, " }};\n"); - } - - -/* - * fldnames - output the initializer for a descriptor for the field name. - */ -static void fldnames(fields) -struct fldname *fields; - { - register char *name; - - if (fields == NULL) - return; - fldnames(fields->next); - name = fields->name; - fprintf(inclfile, " {%d, \"%s\"},\n", strlen(name), name); - } - -/* - * implproto - print prototype for function implementing a run-time operation. - */ -void implproto(ip) -struct implement *ip; - { - if (ip->iconc_flgs & ProtoPrint) - return; /* only print prototype once */ - fprintf(inclfile, "int %c%c%c_%s ", ip->oper_typ, ip->prefix[0], - ip->prefix[1], ip->name); - fprintf(inclfile, "(int r_nargs, dptr r_args, dptr r_rslt, "); - fprintf(inclfile,"continuation r_s_cont);\n"); - ip->iconc_flgs |= ProtoPrint; - } - -/* - * const_blks - output blocks for cset and real constants. - */ -void const_blks() - { - register int i; - register struct centry *cptr; - - fprintf(inclfile, "\n"); - for (i = 0; i < CHSize; i++) - for (cptr = chash[i]; cptr != NULL; cptr = cptr->blink) { - switch (cptr->flag) { - case F_CsetLit: - nxt_pre(cptr->prefix, pre, PrfxSz); - cptr->prefix[PrfxSz] = '\0'; - fprintf(inclfile, "struct b_cset BDC%s = ", cptr->prefix); - cset_init(inclfile, cptr->u.cset); - break; - case F_RealLit: - nxt_pre(cptr->prefix, pre, PrfxSz); - cptr->prefix[PrfxSz] = '\0'; - fprintf(inclfile, "struct b_real BDR%s = {T_Real, %s};\n", - cptr->prefix, cptr->image); - break; - } - } - } - -/* - * reccnstr - output record constructors. - */ -void recconstr(r) -struct rentry *r; - { - register char *name; - int optim; - int nfields; - - if (r == NULL) - return; - recconstr(r->next); - - name = r->name; - nfields = r->nfields; - - /* - * Does this record constructor use optimized calling conventions? - */ - optim = glookup(name)->flag & F_SmplInv; - - fprintf(codefile, "\n"); - fprintf(codefile, "static int R%s_%s(r_nargs, r_args, r_rslt", r->prefix, - name); - if (!optim) - fprintf(codefile, ", r_s_cont"); /* continuation is passed */ - fprintf(codefile, ")\n"); - fprintf(codefile, "int r_nargs;\n"); - fprintf(codefile, "dptr r_args;\n"); - fprintf(codefile, "dptr r_rslt;\n"); - if (!optim) - fprintf(codefile, "continuation r_s_cont;\n"); - fprintf(codefile, " {\n"); - fprintf(codefile, " register int i;\n"); - fprintf(codefile, " register struct b_record *rp;\n"); - fprintf(codefile, "\n"); - fprintf(codefile, " rp = alcrecd(%d, (union block *)&BR%s_%s);\n", - nfields, r->prefix, name); - fprintf(codefile, " if (rp == NULL) {\n"); - fprintf(codefile, " err_msg(307, NULL);\n"); - if (err_conv) - fprintf(codefile, " return A_Resume;\n"); - fprintf(codefile, " }\n"); - fprintf(codefile, " for (i = %d; i >= 0; i--)\n", nfields - 1); - fprintf(codefile, " if (i < r_nargs)\n"); - fprintf(codefile, " deref(&r_args[i], &rp->fields[i]);\n"); - fprintf(codefile, " else\n"); - fprintf(codefile, " rp->fields[i] = nulldesc;\n"); - fprintf(codefile, " r_rslt->vword.bptr = (union block *)rp;\n"); - fprintf(codefile, " r_rslt->dword = D_Record;\n"); - fprintf(codefile, " return A_Continue;\n"); - fprintf(codefile, " }\n"); - } - -/* - * outerfnc - output code for the outer function implementing a procedure. - */ -void outerfnc(fnc) -struct c_fnc *fnc; - { - char *prefix; - char *name; - char *cnt_var; - char *sep; - int ntend; - int first_arg; - int nparms; - int optim; /* optimized interface: no arg list adjustment */ - int ret_flag; -#ifdef OptimizeLoop - int i; -#endif /* OptimizeLoop */ - - prefix = cur_proc->prefix; - name = cur_proc->name; - ntend = cur_proc->tnd_loc + num_tmp; - ChkPrefix(fnc->prefix); - optim = glookup(name)->flag & F_SmplInv; - nparms = Abs(cur_proc->nargs); - ret_flag = cur_proc->ret_flag; - - fprintf(codefile, "\n"); - if (optim) { - /* - * Arg list adjustment and dereferencing are done at call site. - * Use simplified interface. Output both function header and - * prototype. - */ - sep = ""; - fprintf(inclfile, "static int P%s_%s (", prefix, name); - fprintf(codefile, "static int P%s_%s(", prefix, name); - if (nparms != 0) { - fprintf(inclfile, "dptr r_args"); - fprintf(codefile, "r_args"); - sep = ", "; - } - if (ret_flag & (DoesRet | DoesSusp)) { - fprintf(inclfile, "%sdptr r_rslt", sep); - fprintf(codefile, "%sr_rslt", sep); - sep = ", "; - } - if (ret_flag & DoesSusp) { - fprintf(inclfile, "%scontinuation r_s_cont", sep); - fprintf(codefile, "%sr_s_cont", sep); - sep = ", "; - } - if (*sep == '\0') - fprintf(inclfile, "void"); - fprintf(inclfile, ");\n"); - fprintf(codefile, ")\n"); - if (nparms != 0) - fprintf(codefile, "dptr r_args;\n"); - if (ret_flag & (DoesRet | DoesSusp)) - fprintf(codefile, "dptr r_rslt;\n"); - if (ret_flag & DoesSusp) - fprintf(codefile, "continuation r_s_cont;\n"); - } - else { - /* - * General invocation interface. Output function header; prototype has - * already been produced. - */ - fprintf(codefile, - "static int P%s_%s(r_nargs, r_args, r_rslt, r_s_cont)\n", prefix, - name); - fprintf(codefile, "int r_nargs;\n"); - fprintf(codefile, "dptr r_args;\n"); - fprintf(codefile, "dptr r_rslt;\n"); - fprintf(codefile, "continuation r_s_cont;\n"); - } - - fprintf(codefile, "{\n"); - fprintf(codefile, " struct PF%s_%s r_frame;\n", prefix, name); - fprintf(codefile, " register int r_signal;\n"); - fprintf(codefile, " int i;\n"); - if (Type(Tree1(cur_proc->tree)) != N_Empty) - fprintf(codefile, " static int first_time = 1;"); - fprintf(codefile, "\n"); - fprintf(codefile, " r_frame.old_pfp = pfp;\n"); - fprintf(codefile, " pfp = (struct p_frame *)&r_frame;\n"); - fprintf(codefile, " r_frame.old_argp = glbl_argp;\n"); - if (!optim || ret_flag & (DoesRet | DoesSusp)) - fprintf(codefile, " r_frame.rslt = r_rslt;\n"); - else - fprintf(codefile, " r_frame.rslt = NULL;\n"); - if (!optim || ret_flag & DoesSusp) - fprintf(codefile, " r_frame.succ_cont = r_s_cont;\n"); - else - fprintf(codefile, " r_frame.succ_cont = NULL;\n"); - fprintf(codefile, "\n"); -#ifdef OptimizeLoop - if (ntend > 0) { - if (ntend < LoopThreshold) - for (i=0; i < ntend ;i++) - fprintf(codefile, " r_frame.tend.d[%d] = nulldesc;\n", i); - else { - fprintf(codefile, " for (i = 0; i < %d; ++i)\n", ntend); - fprintf(codefile, " r_frame.tend.d[i] = nulldesc;\n"); - } - } -#else /* OptimizeLoop */ - fprintf(codefile, " for (i = 0; i < %d; ++i)\n", ntend); - fprintf(codefile, " r_frame.tend.d[i] = nulldesc;\n"); -#endif /* OptimizeLoop */ - if (optim) { - /* - * Dereferencing and argument list adjustment is done at the call - * site. There is not much to do here. - */ - if (nparms == 0) - fprintf(codefile, " glbl_argp = NULL;\n"); - else - fprintf(codefile, " glbl_argp = r_args;\n"); - } - else { - /* - * Dereferencing and argument list adjustment must be done by - * the procedure itself. - */ - first_arg = ntend; - ntend += nparms; - if (cur_proc->nargs < 0) { - /* - * varargs - construct a list into the last argument. - */ - nparms -= 1; - if (nparms == 0) - cnt_var = "r_nargs"; - else { - fprintf(codefile, " i = r_nargs - %d;\n", nparms); - cnt_var = "i"; - } - fprintf(codefile," if (%s <= 0)\n", cnt_var); - fprintf(codefile," varargs(NULL, 0, &r_frame.tend.d[%d]);\n", - first_arg + nparms); - fprintf(codefile," else\n"); - fprintf(codefile, - " varargs(&r_args[%d], %s, &r_frame.tend.d[%d]);\n", nparms, - cnt_var, first_arg + nparms); - } - if (nparms > 0) { - /* - * Output code to dereference argument or supply default null - * value. - */ -#ifdef OptimizeLoop - fprintf(codefile, " for (i = 0; i < r_nargs ; ++i)\n"); - fprintf(codefile, " deref(&r_args[i], &r_frame.tend.d[i + %d]);\n", first_arg); - fprintf(codefile, " for(i = r_nargs; i < %d ; ++i)\n", nparms); - fprintf(codefile, " r_frame.tend.d[i + %d] = nulldesc;\n", - first_arg); -#else /* OptimizeLoop */ - fprintf(codefile, " for (i = 0; i < %d; ++i)\n", nparms); - fprintf(codefile, " if (i < r_nargs)\n"); - fprintf(codefile, - " deref(&r_args[i], &r_frame.tend.d[i + %d]);\n", - first_arg); - fprintf(codefile, " else\n"); - fprintf(codefile, " r_frame.tend.d[i + %d] = nulldesc;\n", - first_arg); -#endif /* OptimizeLoop */ - } - fprintf(codefile, " glbl_argp = &r_frame.tend.d[%d];\n", first_arg); - } - fprintf(codefile, " r_frame.tend.num = %d;\n", ntend); - fprintf(codefile, " r_frame.tend.previous = tend;\n"); - fprintf(codefile, " tend = (struct tend_desc *)&r_frame.tend;\n"); - if (line_info) { - fprintf(codefile, " r_frame.debug.old_line = line_num;\n"); - fprintf(codefile, " r_frame.debug.old_fname = file_name;\n"); - } - if (debug_info) { - fprintf(codefile, " r_frame.debug.proc = (struct b_proc *)&BP%s_%s;\n", - prefix, name); - fprintf(codefile, " if (k_trace) ctrace();\n"); - fprintf(codefile, " ++k_level;\n\n"); - } - fprintf(codefile, "\n"); - - /* - * Output definition for procedure frame. - */ - prt_frame(prefix, ntend, num_itmp, num_dtmp, num_sbuf, num_cbuf); - - /* - * Output code to implement procedure body. - */ - prtcode(&(fnc->cd), 1); - fprintf(codefile, " }\n"); - } - -/* - * prt_fnc - output C function that implements a continuation. - */ -void prt_fnc(fnc) -struct c_fnc *fnc; - { - struct code *sig; - char *name; - char *prefix; - - if (fnc->flag & CF_SigOnly) { - /* - * This function only returns a signal. A shared function is used in - * its place. Make sure that function has been printed. - */ - sig = fnc->cd.next->SigRef->sig; - if (sig->cd_id != C_Resume) { - sig = ChkBound(sig); - if (!(sig->LabFlg & FncPrtd)) { - ChkSeqNum(sig); - fprintf(inclfile, "static int sig_%d (void);\n", - sig->SeqNum); - - fprintf(codefile, "\n"); - fprintf(codefile, "static int sig_%d()\n", sig->SeqNum); - fprintf(codefile, " {\n"); - fprintf(codefile, " return %d; /* %s */\n", sig->SeqNum, - sig->Desc); - fprintf(codefile, " }\n"); - sig->LabFlg |= FncPrtd; - } - } - } - else { - ChkPrefix(fnc->prefix); - prefix = fnc->prefix; - name = cur_proc->name; - - fprintf(inclfile, "static int P%s_%s (void);\n", prefix, name); - - fprintf(codefile, "\n"); - fprintf(codefile, "static int P%s_%s()\n", prefix, name); - fprintf(codefile, " {\n"); - if (fnc->flag & CF_Coexpr) - fprintf(codefile, "#ifdef Coexpr\n"); - - prefix = fnc->frm_prfx; - - fprintf(codefile, " register int r_signal;\n"); - fprintf(codefile, " register struct PF%s_%s *r_pfp;\n", prefix, name); - fprintf(codefile, "\n"); - fprintf(codefile, " r_pfp = (struct PF%s_%s *)pfp;\n", prefix, name); - prtcode(&(fnc->cd), 0); - if (fnc->flag & CF_Coexpr) { - fprintf(codefile, "#else\t\t\t\t\t/* Coexpr */\n"); - fprintf(codefile, " fatalerr(401, NULL);\n"); - fprintf(codefile, "#endif\t\t\t\t\t/* Coexpr */\n"); - } - fprintf(codefile, " }\n"); - } - } - -/* - * prt_frame - output the definition for a procedure frame. - */ -void prt_frame(prefix, ntend, n_itmp, n_dtmp, n_sbuf, n_cbuf) -char *prefix; -int ntend; -int n_itmp; -int n_dtmp; -int n_sbuf; -int n_cbuf; - { - int i; - - /* - * Output standard part of procedure frame including tended - * descriptors. - */ - fprintf(inclfile, "\n"); - fprintf(inclfile, "struct PF%s_%s {\n", prefix, cur_proc->name); - fprintf(inclfile, " struct p_frame *old_pfp;\n"); - fprintf(inclfile, " dptr old_argp;\n"); - fprintf(inclfile, " dptr rslt;\n"); - fprintf(inclfile, " continuation succ_cont;\n"); - fprintf(inclfile, " struct {\n"); - fprintf(inclfile, " struct tend_desc *previous;\n"); - fprintf(inclfile, " int num;\n"); - fprintf(inclfile, " struct descrip d[%d];\n", MinOne(ntend)); - fprintf(inclfile, " } tend;\n"); - - if (line_info) { /* must be true if debug_info is true */ - fprintf(inclfile, " struct debug debug;\n"); - } - - /* - * Output declarations for the integer, double, string buffer, - * and cset buffer work areas of the frame. - */ - for (i = 0; i < n_itmp; ++i) - fprintf(inclfile, " word i%d;\n", i); - for (i = 0; i < n_dtmp; ++i) - fprintf(inclfile, " double d%d;\n", i); - if (n_sbuf > 0) - fprintf(inclfile, " char sbuf[%d][MaxCvtLen];", n_sbuf); - if (n_cbuf > 0) - fprintf(inclfile, " struct b_cset cbuf[%d];", n_cbuf); - fprintf(inclfile, " };\n"); - } - -/* - * prtcode - print a list of C code. - */ -static void prtcode(cd, outer) -struct code *cd; -int outer; - { - struct lentry *var; - struct centry *lit; - struct code *sig; - int n; - - for ( ; cd != NULL; cd = cd->next) { - switch (cd->cd_id) { - case C_Null: - break; - - case C_NamedVar: - /* - * Construct a reference to a named variable in a result - * location. - */ - var = cd->NamedVar; - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".dword = D_Var;\n"); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".vword.descptr = &"); - prt_var(var, outer); - fprintf(codefile, ";\n"); - break; - - case C_CallSig: - /* - * Call to C function that returns a signal along with signal - * handling code. - */ - if (opt_sgnl) - good_clsg(cd, outer); - else - smpl_clsg(cd, outer); - break; - - case C_RetSig: - /* - * Return a signal. - */ - sig = cd->SigRef->sig; - if (sig->cd_id == C_Resume) - fprintf(codefile, " return A_Resume;\n"); - else { - sig = ChkBound(sig); - ChkSeqNum(sig); - fprintf(codefile, " return %d; /* %s */\n", sig->SeqNum, - sig->Desc); - } - break; - - case C_Goto: - /* - * goto label. - */ - ChkSeqNum(cd->Lbl); - fprintf(codefile, " goto L%d /* %s */;\n", cd->Lbl->SeqNum, - cd->Lbl->Desc); - break; - - case C_Label: - /* - * numbered label. - */ - if (cd->RefCnt > 0) { - ChkSeqNum(cd); - fprintf(codefile, "L%d: ; /* %s */\n", cd->SeqNum, cd->Desc); - } - break; - - case C_Lit: - /* - * Assign literal value to a result location. - */ - lit = cd->Literal; - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - switch (lit->flag) { - case F_CsetLit: - fprintf(codefile, ".dword = D_Cset;\n"); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".vword.bptr = (union block *)&BDC%s;\n", - lit->prefix); - break; - case F_IntLit: - if (lit->u.intgr == -1) { - /* - * Large integer literal - output string and convert - * to integer. - */ - fprintf(codefile, ".vword.sptr = \"%s\";\n", lit->image); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".dword = %d;\n", strlen(lit->image)); - fprintf(codefile, " cnv_int(&"); - val_loc(cd->Rslt, outer); - fprintf(codefile, ", &"); - val_loc(cd->Rslt, outer); - fprintf(codefile, ");\n"); - } - else { - /* - * Ordinary integer literal. - */ - fprintf(codefile, ".dword = D_Integer;\n"); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".vword.integr = %ld;\n", lit->u.intgr); - } - break; - case F_RealLit: - fprintf(codefile, ".dword = D_Real;\n"); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".vword.bptr = (union block *)&BDR%s;\n", - lit->prefix); - break; - case F_StrLit: - fprintf(codefile, ".vword.sptr = "); - if (lit->length == 0) { - /* - * Placing an empty string at the end of the string region - * allows some concatenation optimizations at run time. - */ - fprintf(codefile, "strfree;\n"); - n = 0; - } - else { - fprintf(codefile, "\""); - n = prt_i_str(codefile, lit->image, lit->length); - fprintf(codefile, "\";\n"); - } - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".dword = %d;\n", n); - break; - } - break; - - case C_PFail: - /* - * Procedure failure - this code occurs once near the end of - * the procedure. - */ - if (debug_info) { - fprintf(codefile, " --k_level;\n"); - fprintf(codefile, " if (k_trace) failtrace();\n"); - } - fprintf(codefile, " tend = r_frame.tend.previous;\n"); - fprintf(codefile, " pfp = r_frame.old_pfp;\n"); - fprintf(codefile, " glbl_argp = r_frame.old_argp;\n"); - if (line_info) { - fprintf(codefile, " line_num = r_frame.debug.old_line;\n"); - fprintf(codefile, " file_name = r_frame.debug.old_fname;\n"); - } - fprintf(codefile, " return A_Resume;\n"); - break; - - case C_PRet: - /* - * Procedure return - this code occurs once near the end of - * the procedure. - */ - if (debug_info) { - fprintf(codefile, " --k_level;\n"); - fprintf(codefile, " if (k_trace) rtrace();\n"); - } - fprintf(codefile, " tend = r_frame.tend.previous;\n"); - fprintf(codefile, " pfp = r_frame.old_pfp;\n"); - fprintf(codefile, " glbl_argp = r_frame.old_argp;\n"); - if (line_info) { - fprintf(codefile, " line_num = r_frame.debug.old_line;\n"); - fprintf(codefile, " file_name = r_frame.debug.old_fname;\n"); - } - fprintf(codefile, " return A_Continue;\n"); - break; - - case C_PSusp: - /* - * Procedure suspend - call success continuation. - */ - prtpccall(outer); - break; - - case C_Break: - fprintf(codefile, " break;\n"); - break; - - case C_If: - /* - * C if statement. - */ - fprintf(codefile, " if ("); - prt_ary(cd->Cond, outer); - fprintf(codefile, ")\n "); - prtcode(cd->ThenStmt, outer); - break; - - case C_CdAry: - /* - * Array of code fragments. - */ - fprintf(codefile, " "); - prt_ary(cd, outer); - fprintf(codefile, "\n"); - break; - - case C_LBrack: - fprintf(codefile, " {\n"); - break; - - case C_RBrack: - fprintf(codefile, " }\n"); - break; - - case C_Create: - /* - * Code to create a co-expression and assign it to a result - * location. - */ - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile , ".vword.bptr = (union block *)create("); - prt_cont(cd->Cont); - fprintf(codefile, - ", (struct b_proc *)&BP%s_%s, %d, sizeof(word) * %d);\n", - cur_proc->prefix, cur_proc->name, cd->NTemps, cd->WrkSize); - fprintf(codefile, " "); - val_loc(cd->Rslt, outer); - fprintf(codefile, ".dword = D_Coexpr;\n"); - break; - - case C_SrcLoc: - /* - * Update file name and line number information. - */ - if (cd->FileName != NULL) { - fprintf(codefile, " file_name = \""); - prt_i_str(codefile, cd->FileName, strlen(cd->FileName)); - fprintf(codefile, "\";\n"); - } - if (cd->LineNum != 0) - fprintf(codefile, " line_num = %d;\n", cd->LineNum); - break; - } - } - } - -/* - * prt_var - output C code to reference an Icon named variable. - */ -static void prt_var(var, outer) -struct lentry *var; -int outer; - { - switch (var->flag) { - case F_Global: - fprintf(codefile, "globals[%d]", var->val.global->index); - break; - case F_Static: - fprintf(codefile, "statics[%d]", var->val.index); - break; - case F_Dynamic: - frame(outer); - fprintf(codefile, ".tend.d[%d]", var->val.index); - break; - case F_Argument: - fprintf(codefile, "glbl_argp[%d]", var->val.index); - } - - /* - * Include an identifying comment. - */ - fprintf(codefile, " /* %s */", var->name); - } - -/* - * prt_ary - print an array of code fragments. - */ -static void prt_ary(cd, outer) -struct code *cd; -int outer; - { - int i; - - for (i = 0; cd->ElemTyp(i) != A_End; ++i) - switch (cd->ElemTyp(i)) { - case A_Str: - /* - * Simple C code in a string. - */ - fprintf(codefile, "%s", cd->Str(i)); - break; - case A_ValLoc: - /* - * Value location (usually variable of some sort). - */ - val_loc(cd->ValLoc(i), outer); - break; - case A_Intgr: - /* - * Integer. - */ - fprintf(codefile, "%d", cd->Intgr(i)); - break; - case A_ProcCont: - /* - * Current procedure call's success continuation. - */ - if (outer) - fprintf(codefile, "r_s_cont"); - else - fprintf(codefile, "r_pfp->succ_cont"); - break; - case A_SBuf: - /* - * One of the string buffers. - */ - frame(outer); - fprintf(codefile, ".sbuf[%d]", cd->Intgr(i)); - break; - case A_CBuf: - /* - * One of the cset buffers. - */ - fprintf(codefile, "&("); - frame(outer); - fprintf(codefile, ".cbuf[%d])", cd->Intgr(i)); - break; - case A_Ary: - /* - * A subarray of code fragments. - */ - prt_ary(cd->Array(i), outer); - break; - } - } - -/* - * frame - access to the procedure frame. Access directly from outer function, - * but access through r_pfp from a continuation. - */ -static void frame(outer) -int outer; - { - if (outer) - fprintf(codefile, "r_frame"); - else - fprintf(codefile, "(*r_pfp)"); - } - -/* - * prtpccall - print procedure continuation call. - */ -static void prtpccall(outer) -int outer; - { - int first_arg; - int optim; /* optimized interface: no arg list adjustment */ - - first_arg = cur_proc->tnd_loc + num_tmp; - optim = glookup(cur_proc->name)->flag & F_SmplInv; - - /* - * The only signal to be handled in this procedure is - * resumption, the rest must be passed on. - */ - if (cur_proc->nargs != 0 && optim && !outer) { - fprintf(codefile, " {\n"); - fprintf(codefile, " dptr r_argp_sav;\n"); - fprintf(codefile, "\n"); - fprintf(codefile, " r_argp_sav = glbl_argp;\n"); - } - if (debug_info) { - fprintf(codefile, " --k_level;\n"); - fprintf(codefile, " if (k_trace) strace();\n"); - } - fprintf(codefile, " pfp = "); - frame(outer); - fprintf(codefile, ".old_pfp;\n"); - fprintf(codefile, " glbl_argp = "); - frame(outer); - fprintf(codefile, ".old_argp;\n"); - if (line_info) { - fprintf(codefile, " line_num = "); - frame(outer); - fprintf(codefile, ".debug.old_line;\n"); - fprintf(codefile, " file_name = "); - frame(outer); - fprintf(codefile , ".debug.old_fname;\n"); - } - fprintf(codefile, " r_signal = (*"); - if (outer) - fprintf(codefile, "r_s_cont)();\n"); - else - fprintf(codefile, "r_pfp->succ_cont)();\n"); - fprintf(codefile, " if (r_signal != A_Resume) {\n"); - if (outer) - fprintf(codefile, " tend = r_frame.tend.previous;\n"); - fprintf(codefile, " return r_signal;\n"); - fprintf(codefile, " }\n"); - fprintf(codefile, " pfp = (struct p_frame *)&"); - frame(outer); - fprintf(codefile, ";\n"); - if (cur_proc->nargs == 0) - fprintf(codefile, " glbl_argp = NULL;\n"); - else { - if (optim) { - if (outer) - fprintf(codefile, " glbl_argp = r_args;\n"); - else - fprintf(codefile, " glbl_argp = r_argp_sav;\n"); - } - else { - fprintf(codefile, " glbl_argp = &"); - if (outer) - fprintf(codefile, "r_frame."); - else - fprintf(codefile, "r_pfp->"); - fprintf(codefile, "tend.d[%d];\n", first_arg); - } - } - if (debug_info) { - fprintf(codefile, " if (k_trace) atrace();\n"); - fprintf(codefile, " ++k_level;\n"); - } - if (cur_proc->nargs != 0 && optim && !outer) - fprintf(codefile, " }\n"); - } - -/* - * smpl_clsg - print call and signal handling code, but nothing fancy. - */ -static void smpl_clsg(call, outer) -struct code *call; -int outer; - { - struct sig_act *sa; - - fprintf(codefile, " r_signal = "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - if (call->Flags & ForeignSig) - chkforgn(outer); - fprintf(codefile, " switch (r_signal) {\n"); - for (sa = call->SigActs; sa != NULL; sa = sa->next) { - fprintf(codefile, " case "); - prt_cond(sa->sig); - fprintf(codefile, ":\n "); - prtcode(sa->cd, outer); - } - fprintf(codefile, " }\n"); - } - -/* - * chkforgn - produce code to see if the current signal belongs to a - * procedure higher up the call chain and pass it along if it does. - */ -static void chkforgn(outer) -int outer; - { - fprintf(codefile, " if (pfp != (struct p_frame *)"); - if (outer) { - fprintf(codefile, "&r_frame) {\n"); - fprintf(codefile, " tend = r_frame.tend.previous;\n"); - } - else - fprintf(codefile, "r_pfp) {\n"); - fprintf(codefile, " return r_signal;\n"); - fprintf(codefile, " }\n"); - } - -/* - * good_clsg - print call and signal handling code and do a good job. - */ -static void good_clsg(call, outer) -struct code *call; -int outer; - { - struct sig_act *sa, *sa1, *nxt_sa; - int ncases; /* the number of cases - each may have multiple case labels */ - int ncaselbl; /* the number of case labels */ - int nbreak; /* the number of cases that just break out of the switch */ - int nretsig; /* the number of cases that just pass along signal */ - int sig_var; - int dflt; - struct code *cond; - struct code *then_cd; - - /* - * Decide whether to use "break;", "return r_signal;", or nothing as - * the default case. - */ - nretsig = 0; - nbreak = 0; - for (sa = call->SigActs; sa != NULL; sa = sa->next) { - if (sa->cd->cd_id == C_RetSig && sa->sig == sa->cd->SigRef->sig) { - /* - * The action returns the same signal detected by this case. - */ - ++nretsig; - } - else if (sa->cd->cd_id == C_Break) { - cond = sa->sig; /* if there is only one break, we may want this */ - ++nbreak; - } - } - dflt = DfltNone; - ncases = 0; - if (nbreak > 0 && nbreak >= nretsig) { - /* - * There are at least as many "break;"s as "return r_signal;"s, so - * use "break;" for default clause. - */ - dflt = DfltBrk; - ncases = 1; - } - else if (nretsig > 1) { - /* - * There is more than one case that returns the same signal it - * detects and there are more of them than "break;"s, to make - * "return r_signal;" the default clause. - */ - dflt = DfltRetSig; - ncases = 1; - } - - /* - * Gather case labels together for each case, ignoring cases that - * fall under the default. This involves constructing a new - * improved call->SigActs list. - */ - ncaselbl = ncases; - sa = call->SigActs; - call->SigActs = NULL; - for ( ; sa != NULL; sa = nxt_sa) { - nxt_sa = sa->next; - /* - * See if we have already found a case with the same action. - */ - sa1 = call->SigActs; - switch (sa->cd->cd_id) { - case C_Break: - if (dflt == DfltBrk) - continue; - while (sa1 != NULL && sa1->cd->cd_id != C_Break) - sa1 = sa1->next; - break; - case C_RetSig: - if (dflt == DfltRetSig && sa->cd->SigRef->sig == sa->sig) - continue; - while (sa1 != NULL && (sa1->cd->cd_id != C_RetSig || - sa1->cd->SigRef->sig != sa->cd->SigRef->sig)) - sa1 = sa1->next; - break; - default: /* C_Goto */ - while (sa1 != NULL && (sa1->cd->cd_id != C_Goto || - sa1->cd->Lbl != sa->cd->Lbl)) - sa1 = sa1->next; - break; - } - ++ncaselbl; - if (sa1 == NULL) { - /* - * First time we have seen this action, create a new case. - */ - ++ncases; - sa->next = call->SigActs; - call->SigActs = sa; - } - else { - /* - * We can share the action of another case label. - */ - sa->shar_act = sa1->shar_act; - sa1->shar_act = sa; - } - } - - /* - * If we might receive a "foreign" signal that belongs to a procedure - * further down the call chain, put the signal in "r_signal" then - * check for this condition. - */ - sig_var = 0; - if (call->Flags & ForeignSig) { - fprintf(codefile, " r_signal = "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - chkforgn(outer); - sig_var = 1; - } - - /* - * Determine the best way to handle the signal returned from the call. - */ - if (ncases == 0) { - /* - * Any further signal checking has been optimized away. Execution - * just falls through to subsequent code. If the call has not - * been done, do it. - */ - if (!sig_var) { - fprintf(codefile, " "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - } - } - else if (ncases == 1) { - if (dflt == DfltRetSig || ncaselbl == nretsig) { - /* - * All this call does is pass the signal on. See if we have - * done the call yet. - */ - if (sig_var) - fprintf(codefile, " return r_signal;"); - else { - fprintf(codefile, " return "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - } - } - else { - /* - * We know what to do without looking at the signal. Make sure - * we have done the call. If the action is not simply "break" - * out signal checking, execute it. - */ - if (!sig_var) { - fprintf(codefile, " "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - } - if (dflt != DfltBrk) - prtcode(call->SigActs->cd, outer); - } - } - else { - /* - * We have at least two cases. If we have a default action of returning - * the signal without looking at it, make sure it is in "r_signal". - */ - if (!sig_var && dflt == DfltRetSig) { - fprintf(codefile, " r_signal = "); - prtcall(call, outer); - fprintf(codefile, ";\n"); - sig_var = 1; - } - - if (ncaselbl == 2) { - /* - * We can use an if statement. If we need the signal in "r_signal", - * it is already there. - */ - fprintf(codefile, " if ("); - if (sig_var) - fprintf(codefile, "r_signal"); - else - prtcall(call, outer); - - cond = call->SigActs->sig; - then_cd = call->SigActs->cd; - - /* - * If the "then" clause is a no-op ("break;" from a switch), - * prepare to eliminate it by reversing the test in the - * condition. - */ - if (then_cd->cd_id == C_Break) - fprintf(codefile, " != "); - else - fprintf(codefile, " == "); - - prt_cond(cond); - fprintf(codefile, ")\n "); - - if (then_cd->cd_id == C_Break) { - /* - * We have reversed the test, so we need to use the default - * code. However, because a "break;" exists and it is not - * default, "return r_signal;" must be the default. - */ - fprintf(codefile, " return r_signal;\n"); - } - else { - /* - * Print the "then" clause and determine what the "else" clause - * is. - */ - prtcode(then_cd, outer); - if (call->SigActs->next != NULL) { - fprintf(codefile, " else\n "); - prtcode(call->SigActs->next->cd, outer); - } - else if (dflt == DfltRetSig) { - fprintf(codefile, " else\n"); - fprintf(codefile, " return r_signal;\n"); - } - } - } - else if (ncases == 2 && nbreak == 1) { - /* - * We can use an if-then statement with a negated test. Note, - * the non-break case is not "return r_signal" or we would have - * ncaselbl = 2, making the last test true. This also means that - * break is the default (the break condition was saved). - */ - fprintf(codefile, " if ("); - if (sig_var) - fprintf(codefile, "r_signal"); - else - prtcall(call, outer); - fprintf(codefile, " != "); - prt_cond(cond); - fprintf(codefile, ") {\n "); - prtcode(call->SigActs->cd, outer); - fprintf(codefile, " }\n"); - } - else { - /* - * We must use a full case statement. If we need the signal in - * "r_signal", it is already there. - */ - fprintf(codefile, " switch ("); - if (sig_var) - fprintf(codefile, "r_signal"); - else - prtcall(call, outer); - fprintf(codefile, ") {\n"); - - /* - * Print the cases - */ - for (sa = call->SigActs; sa != NULL; sa = sa->next) { - for (sa1 = sa; sa1 != NULL; sa1 = sa1->shar_act) { - fprintf(codefile, " case "); - prt_cond(sa1->sig); - fprintf(codefile, ":\n"); - } - fprintf(codefile, " "); - prtcode(sa->cd, outer); - } - - /* - * If we have a default action and it is not break, print it. - */ - if (dflt == DfltRetSig) { - fprintf(codefile, " default:\n"); - fprintf(codefile, " return r_signal;\n"); - } - - fprintf(codefile, " }\n"); - } - } - } - -/* - * prtcall - print call. - */ -static void prtcall(call, outer) -struct code *call; -int outer; - { - /* - * Either the operation or the continuation may be missing, but not - * both. - */ - if (call->OperName == NULL) { - prt_cont(call->Cont); - fprintf(codefile, "()"); - } - else { - fprintf(codefile, "%s(", call->OperName); - if (call->ArgLst != NULL) - prt_ary(call->ArgLst, outer); - if (call->Cont == NULL) { - if (call->Flags & NeedCont) { - /* - * The operation requires a continuation argument even though - * this call does not include one, pass the NULL pointer. - */ - if (call->ArgLst != NULL) - fprintf(codefile, ", "); - fprintf(codefile, "(continuation)NULL"); - } - } - else { - /* - * Pass the success continuation. - */ - if (call->ArgLst != NULL) - fprintf(codefile, ", "); - prt_cont(call->Cont); - } - fprintf(codefile, ")"); - } - } - -/* - * prt_cont - print the name of a continuation. - */ -static void prt_cont(cont) -struct c_fnc *cont; - { - struct code *sig; - - if (cont->flag & CF_SigOnly) { - /* - * This continuation only returns a signal. All continuations - * returning the same signal are implemented by the same C function. - */ - sig = cont->cd.next->SigRef->sig; - if (sig->cd_id == C_Resume) - fprintf(codefile, "sig_rsm"); - else { - sig = ChkBound(sig); - ChkSeqNum(sig); - fprintf(codefile, "sig_%d", sig->SeqNum); - } - } - else { - /* - * Regular continuation. - */ - ChkPrefix(cont->prefix); - fprintf(codefile, "P%s_%s", cont->prefix, cur_proc->name); - } - } - -/* - * val_loc - output code referencing a value location (usually variable of - * some sort). - */ -static void val_loc(loc, outer) -struct val_loc *loc; -int outer; - { - /* - * See if we need to cast a block pointer to a specific block type - * or if we need to take the address of a location. - */ - if (loc->mod_access == M_BlkPtr && loc->blk_name != NULL) - fprintf(codefile, "(*(struct %s **)&", loc->blk_name); - if (loc->mod_access == M_Addr) - fprintf(codefile, "(&"); - - switch (loc->loc_type) { - case V_Ignore: - fprintf(codefile, "trashcan"); - break; - case V_Temp: - /* - * Temporary descriptor variable. - */ - frame(outer); - fprintf(codefile, ".tend.d[%d]", cur_proc->tnd_loc + loc->u.tmp); - break; - case V_ITemp: - /* - * Temporary C integer variable. - */ - frame(outer); - fprintf(codefile, ".i%d", loc->u.tmp); - break; - case V_DTemp: - /* - * Temporary C double variable. - */ - frame(outer); - fprintf(codefile, ".d%d", loc->u.tmp); - break; - case V_Const: - /* - * Integer constant (used for size of variable part of arg list). - */ - fprintf(codefile, "%d", loc->u.int_const); - break; - case V_NamedVar: - /* - * Icon named variable. - */ - prt_var(loc->u.nvar, outer); - break; - case V_CVar: - /* - * C variable from in-line code. - */ - fprintf(codefile, "%s", loc->u.name); - break; - case V_PRslt: - /* - * Procedure result location. - */ - if (!outer) - fprintf(codefile, "(*r_pfp->rslt)"); - else - fprintf(codefile, "(*r_rslt)"); - break; - } - - /* - * See if we are accessing the vword of a descriptor. - */ - switch (loc->mod_access) { - case M_CharPtr: - fprintf(codefile, ".vword.sptr"); - break; - case M_BlkPtr: - fprintf(codefile, ".vword.bptr"); - if (loc->blk_name != NULL) - fprintf(codefile, ")"); - break; - case M_CInt: - fprintf(codefile, ".vword.integr"); - break; - case M_Addr: - fprintf(codefile, ")"); - break; - } - } - -/* - * prt_cond - print a condition (signal number). - */ -static void prt_cond(cond) -struct code *cond; - { - if (cond == &resume) - fprintf(codefile, "A_Resume"); - else if (cond == &contin) - fprintf(codefile, "A_Continue"); - else if (cond == &fallthru) - fprintf(codefile, "A_FallThru"); - else { - cond = ChkBound(cond); - ChkSeqNum(cond); - fprintf(codefile, "%d /* %s */", cond->SeqNum, cond->Desc); - } - } - -/* - * initpblk - write a procedure block along with initialization up to the - * the array of qualifiers. - */ -static void initpblk(f, c, prefix, name, nquals, nparam, ndynam, nstatic, - frststat) -FILE *f; /* output file */ -int c; /* distinguishes procedures, functions, record constructors */ -char* prefix; /* prefix for name */ -char *name; /* name of routine */ -int nquals; /* number of qualifiers at end of block */ -int nparam; /* number of parameters */ -int ndynam; /* number of dynamic locals or function/record indicator */ -int nstatic; /* number of static locals or record number */ -int frststat; /* index into static array of first static local */ - { - fprintf(f, "B_IProc(%d) B%c%s_%s = ", nquals, c, prefix, name); - fprintf(f, "{T_Proc, %d, %c%s_%s, %d, %d, %d, %d, {", 9 + 2 * nquals, c, - prefix, name, nparam, ndynam, nstatic, frststat); - } - diff --git a/src/iconc/cparse.c b/src/iconc/cparse.c deleted file mode 100644 index b29986d..0000000 --- a/src/iconc/cparse.c +++ /dev/null @@ -1,1940 +0,0 @@ -# define IDENT 257 -# define INTLIT 258 -# define REALLIT 259 -# define STRINGLIT 260 -# define CSETLIT 261 -# define EOFX 262 -# define BREAK 263 -# define BY 264 -# define CASE 265 -# define CREATE 266 -# define DEFAULT 267 -# define DO 268 -# define ELSE 269 -# define END 270 -# define EVERY 271 -# define FAIL 272 -# define GLOBAL 273 -# define IF 274 -# define INITIAL 275 -# define INVOCABLE 276 -# define LINK 277 -# define LOCAL 278 -# define NEXT 279 -# define NOT 280 -# define OF 281 -# define PROCEDURE 282 -# define RECORD 283 -# define REPEAT 284 -# define RETURN 285 -# define STATIC 286 -# define SUSPEND 287 -# define THEN 288 -# define TO 289 -# define UNTIL 290 -# define WHILE 291 -# define BANG 292 -# define MOD 293 -# define AUGMOD 294 -# define AND 295 -# define AUGAND 296 -# define STAR 297 -# define AUGSTAR 298 -# define INTER 299 -# define AUGINTER 300 -# define PLUS 301 -# define AUGPLUS 302 -# define UNION 303 -# define AUGUNION 304 -# define MINUS 305 -# define AUGMINUS 306 -# define DIFF 307 -# define AUGDIFF 308 -# define DOT 309 -# define SLASH 310 -# define AUGSLASH 311 -# define ASSIGN 312 -# define SWAP 313 -# define NMLT 314 -# define AUGNMLT 315 -# define REVASSIGN 316 -# define REVSWAP 317 -# define SLT 318 -# define AUGSLT 319 -# define SLE 320 -# define AUGSLE 321 -# define NMLE 322 -# define AUGNMLE 323 -# define NMEQ 324 -# define AUGNMEQ 325 -# define SEQ 326 -# define AUGSEQ 327 -# define EQUIV 328 -# define AUGEQUIV 329 -# define NMGT 330 -# define AUGNMGT 331 -# define NMGE 332 -# define AUGNMGE 333 -# define SGT 334 -# define AUGSGT 335 -# define SGE 336 -# define AUGSGE 337 -# define QMARK 338 -# define AUGQMARK 339 -# define AT 340 -# define AUGAT 341 -# define BACKSLASH 342 -# define CARET 343 -# define AUGCARET 344 -# define BAR 345 -# define CONCAT 346 -# define AUGCONCAT 347 -# define LCONCAT 348 -# define AUGLCONCAT 349 -# define TILDE 350 -# define NMNE 351 -# define AUGNMNE 352 -# define SNE 353 -# define AUGSNE 354 -# define NEQUIV 355 -# define AUGNEQUIV 356 -# define LPAREN 357 -# define RPAREN 358 -# define PCOLON 359 -# define COMMA 360 -# define MCOLON 361 -# define COLON 362 -# define SEMICOL 363 -# define LBRACK 364 -# define RBRACK 365 -# define LBRACE 366 -# define RBRACE 367 - -# line 145 "cgram.g" -/* - * These commented directives are passed through the first application - * of cpp, then turned into real directives in cgram.g by fixgram.icn. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ccode.h" -#include "cproto.h" -#undef YYSTYPE -#define YYSTYPE nodeptr -#define YYMAXDEPTH 500 - -int idflag; - - - -#define yyclearin yychar = -1 -#define yyerrok yyerrflag = 0 -extern int yychar; -extern int yyerrflag; -#ifndef YYMAXDEPTH -#define YYMAXDEPTH 150 -#endif -#ifndef YYSTYPE -#define YYSTYPE int -#endif -YYSTYPE yylval, yyval; -# define YYERRCODE 256 - -# line 441 "cgram.g" - - -/* - * xfree(p) -- used with free(p) macro to avoid compiler errors from - * miscast free calls generated by Yacc. - */ - -static void xfree(p) -char *p; -{ - free(p); -} - -#define free(p) xfree((char*)p) -int yyexca[] ={ --1, 0, - 262, 2, - 273, 2, - 276, 2, - 277, 2, - 282, 2, - 283, 2, - -2, 0, --1, 1, - 0, -1, - -2, 0, --1, 20, - 270, 40, - 363, 42, - -2, 0, --1, 86, - 264, 42, - 268, 42, - 269, 42, - 281, 42, - 288, 42, - 289, 42, - 293, 42, - 294, 42, - 296, 42, - 298, 42, - 300, 42, - 302, 42, - 304, 42, - 306, 42, - 308, 42, - 311, 42, - 312, 42, - 313, 42, - 314, 42, - 315, 42, - 316, 42, - 317, 42, - 318, 42, - 319, 42, - 320, 42, - 321, 42, - 322, 42, - 323, 42, - 325, 42, - 327, 42, - 329, 42, - 330, 42, - 331, 42, - 332, 42, - 333, 42, - 334, 42, - 335, 42, - 336, 42, - 337, 42, - 339, 42, - 341, 42, - 344, 42, - 347, 42, - 349, 42, - 352, 42, - 354, 42, - 356, 42, - 358, 42, - 359, 42, - 360, 42, - 361, 42, - 362, 42, - 363, 42, - 365, 42, - 367, 42, - -2, 0, --1, 87, - 358, 42, - 360, 42, - -2, 0, --1, 88, - 363, 42, - 367, 42, - -2, 0, --1, 89, - 360, 42, - 365, 42, - -2, 0, --1, 96, - 264, 42, - 268, 42, - 269, 42, - 281, 42, - 288, 42, - 289, 42, - 293, 42, - 294, 42, - 296, 42, - 298, 42, - 300, 42, - 302, 42, - 304, 42, - 306, 42, - 308, 42, - 311, 42, - 312, 42, - 313, 42, - 314, 42, - 315, 42, - 316, 42, - 317, 42, - 318, 42, - 319, 42, - 320, 42, - 321, 42, - 322, 42, - 323, 42, - 325, 42, - 327, 42, - 329, 42, - 330, 42, - 331, 42, - 332, 42, - 333, 42, - 334, 42, - 335, 42, - 336, 42, - 337, 42, - 339, 42, - 341, 42, - 344, 42, - 347, 42, - 349, 42, - 352, 42, - 354, 42, - 356, 42, - 358, 42, - 359, 42, - 360, 42, - 361, 42, - 362, 42, - 363, 42, - 365, 42, - 367, 42, - -2, 0, --1, 97, - 264, 42, - 268, 42, - 269, 42, - 281, 42, - 288, 42, - 289, 42, - 293, 42, - 294, 42, - 296, 42, - 298, 42, - 300, 42, - 302, 42, - 304, 42, - 306, 42, - 308, 42, - 311, 42, - 312, 42, - 313, 42, - 314, 42, - 315, 42, - 316, 42, - 317, 42, - 318, 42, - 319, 42, - 320, 42, - 321, 42, - 322, 42, - 323, 42, - 325, 42, - 327, 42, - 329, 42, - 330, 42, - 331, 42, - 332, 42, - 333, 42, - 334, 42, - 335, 42, - 336, 42, - 337, 42, - 339, 42, - 341, 42, - 344, 42, - 347, 42, - 349, 42, - 352, 42, - 354, 42, - 356, 42, - 358, 42, - 359, 42, - 360, 42, - 361, 42, - 362, 42, - 363, 42, - 365, 42, - 367, 42, - -2, 0, --1, 111, - 270, 40, - 363, 42, - -2, 0, --1, 117, - 270, 40, - 363, 42, - -2, 0, --1, 182, - 360, 42, - 365, 42, - -2, 0, --1, 183, - 360, 42, - -2, 0, --1, 184, - 358, 42, - 360, 42, - -2, 0, --1, 311, - 358, 42, - 360, 42, - 365, 42, - -2, 0, --1, 313, - 363, 42, - 367, 42, - -2, 0, --1, 335, - 360, 42, - 367, 42, - -2, 0, - }; -# define YYNPROD 203 -# define YYLAST 728 -int yyact[]={ - - 38, 84, 91, 92, 93, 94, 312, 86, 185, 99, - 83, 118, 335, 359, 341, 102, 95, 358, 98, 334, - 311, 311, 355, 85, 51, 329, 314, 20, 103, 96, - 118, 97, 313, 228, 101, 100, 56, 346, 118, 90, - 118, 59, 117, 62, 360, 58, 108, 70, 336, 64, - 311, 57, 228, 55, 60, 326, 184, 228, 310, 119, - 311, 107, 106, 182, 345, 183, 324, 232, 65, 110, - 67, 168, 69, 169, 352, 214, 118, 350, 328, 177, - 41, 356, 71, 174, 50, 175, 73, 61, 325, 52, - 53, 320, 54, 316, 63, 66, 176, 68, 327, 72, - 118, 87, 332, 118, 333, 331, 319, 361, 89, 116, - 88, 305, 38, 84, 91, 92, 93, 94, 118, 86, - 181, 99, 83, 353, 317, 231, 3, 102, 95, 218, - 98, 318, 105, 118, 19, 85, 51, 315, 118, 28, - 103, 96, 29, 97, 217, 321, 101, 100, 56, 309, - 170, 90, 172, 59, 173, 62, 171, 58, 118, 70, - 30, 64, 18, 57, 118, 55, 60, 44, 180, 37, - 179, 178, 113, 24, 104, 114, 25, 330, 351, 306, - 65, 212, 67, 115, 69, 82, 2, 81, 80, 27, - 17, 36, 23, 79, 71, 78, 50, 77, 73, 61, - 76, 52, 53, 75, 54, 74, 63, 66, 49, 68, - 47, 72, 42, 87, 38, 84, 91, 92, 93, 94, - 89, 86, 88, 99, 83, 40, 112, 322, 109, 102, - 95, 34, 98, 273, 274, 111, 33, 85, 51, 12, - 233, 32, 103, 96, 21, 97, 22, 26, 101, 100, - 56, 10, 9, 90, 8, 59, 7, 62, 31, 58, - 6, 70, 5, 64, 1, 57, 0, 55, 60, 13, - 0, 216, 15, 14, 0, 210, 0, 0, 16, 11, - 0, 0, 65, 0, 67, 234, 69, 236, 239, 221, - 222, 223, 224, 225, 226, 227, 71, 230, 50, 229, - 73, 61, 0, 52, 53, 237, 54, 0, 63, 66, - 0, 68, 0, 72, 0, 87, 46, 84, 91, 92, - 93, 94, 89, 86, 88, 99, 83, 45, 0, 0, - 0, 102, 95, 0, 98, 0, 289, 290, 0, 85, - 51, 0, 0, 235, 103, 96, 0, 97, 0, 238, - 101, 100, 56, 0, 0, 90, 0, 59, 0, 62, - 0, 58, 4, 70, 303, 64, 308, 57, 0, 55, - 60, 0, 0, 13, 304, 0, 15, 14, 0, 0, - 0, 0, 16, 11, 65, 0, 67, 0, 69, 338, - 0, 213, 0, 0, 0, 0, 0, 0, 71, 43, - 50, 0, 73, 61, 0, 52, 53, 323, 54, 347, - 63, 66, 35, 68, 152, 72, 0, 87, 0, 133, - 0, 150, 0, 130, 89, 131, 88, 128, 0, 127, - 0, 129, 0, 126, 362, 0, 132, 121, 120, 0, - 140, 123, 122, 0, 147, 164, 146, 0, 139, 158, - 135, 157, 143, 163, 136, 160, 138, 154, 137, 166, - 145, 162, 144, 161, 149, 156, 151, 155, 0, 134, - 0, 0, 124, 0, 125, 0, 153, 141, 211, 148, - 215, 142, 165, 39, 159, 0, 167, 0, 219, 220, - 0, 295, 296, 297, 298, 299, 0, 0, 291, 292, - 293, 294, 0, 35, 0, 0, 0, 339, 340, 35, - 342, 343, 344, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 348, 0, 0, 0, 48, 0, 0, 0, - 0, 0, 0, 354, 0, 0, 0, 0, 0, 0, - 0, 0, 357, 0, 0, 0, 0, 0, 0, 0, - 0, 354, 363, 364, 275, 276, 277, 278, 279, 280, - 281, 282, 283, 284, 285, 286, 287, 288, 0, 0, - 0, 0, 0, 0, 0, 307, 0, 186, 187, 188, - 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, - 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, - 209, 0, 0, 240, 241, 242, 243, 244, 245, 246, - 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, - 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, - 267, 268, 269, 270, 271, 272, 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, 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, 0, 0, 0, 0, - 0, 0, 0, 337, 0, 215, 300, 301, 302, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 349 }; -int yypact[]={ - - -130, -1000, 100, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -95, -229, -1000, -84, -118, -97, -4, -1000, -1000, - -42, -125, -298, -1000, -1000, -1000, -299, -1000, -1000, -316, - -1000, -1000, -288, -103, -161, -321, -219, -279, -1000, -1000, - 125, -1000, 131, -275, -151, -214, -1000, -172, -1000, -301, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -42, -1000, -1000, -42, -42, -42, -42, - -128, -1000, -1000, -1000, -1000, -1000, -42, -42, -42, -42, - -42, -42, -42, -42, -303, -1000, -84, -118, -133, -290, - -125, -42, -125, -42, -1000, -1000, -1000, -42, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, - 60, 60, -42, -256, -42, -108, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -219, -1000, -300, -1000, -361, -331, -339, -1000, -1000, -1000, - -1000, -131, -195, -157, -137, -162, -177, -219, -112, -1000, - -1000, -1000, -125, -292, -303, -182, -308, -265, -1000, -279, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -186, -1000, -275, -275, -275, -275, -275, - -275, -275, -275, -275, -275, -275, -275, -275, -275, -151, - -151, -214, -214, -214, -214, -1000, -1000, -1000, -1000, -1000, - -1000, -1000, -1000, -340, -257, -1000, -348, -1000, -310, -1000, - -1000, -42, -1000, -42, -1000, -42, -42, -352, -42, -42, - -42, -1000, -294, -327, -1000, -1000, -1000, -1000, 60, -1000, - -42, -1000, -1000, -1000, -1000, -42, -1000, -1000, -1000, -219, - -192, -144, -219, -219, -219, -1000, -343, -1000, -284, -1000, - -42, -350, -1000, -318, -255, -1000, -1000, -219, -1000, -144, - -42, -42, -1000, -219, -219 }; -int yypgo[]={ - - 0, 264, 186, 262, 260, 256, 254, 252, 251, 247, - 189, 246, 192, 244, 174, 241, 240, 239, 236, 235, - 231, 228, 227, 226, 191, 391, 169, 483, 225, 80, - 212, 399, 167, 327, 316, 210, 526, 208, 205, 203, - 200, 197, 195, 193, 188, 187, 185, 181, 75, 179, - 178, 74, 177 }; -int yyr1[]={ - - 0, 1, 2, 2, 3, 3, 3, 3, 3, 8, - 9, 9, 10, 10, 10, 7, 11, 11, 12, 12, - 13, 6, 15, 4, 16, 16, 5, 21, 17, 22, - 22, 22, 14, 14, 18, 18, 23, 23, 19, 19, - 20, 20, 25, 25, 24, 24, 26, 26, 27, 27, - 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, - 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, - 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, - 27, 28, 28, 28, 29, 29, 30, 30, 30, 30, - 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, - 30, 31, 31, 31, 32, 32, 32, 32, 32, 33, - 33, 33, 33, 33, 34, 34, 35, 35, 35, 35, - 36, 36, 36, 36, 36, 36, 36, 36, 36, 36, - 36, 36, 36, 36, 36, 36, 36, 36, 36, 36, - 36, 36, 36, 36, 36, 37, 37, 37, 37, 37, - 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, - 37, 37, 37, 37, 37, 37, 37, 37, 43, 43, - 44, 44, 45, 45, 46, 40, 40, 40, 40, 41, - 41, 42, 50, 50, 51, 51, 47, 47, 49, 49, - 38, 38, 38, 38, 39, 52, 52, 52, 48, 48, - 1, 5, 24 }; -int yyr2[]={ - - 0, 5, 0, 4, 3, 3, 3, 3, 3, 5, - 2, 7, 3, 3, 7, 5, 2, 7, 3, 3, - 1, 7, 1, 13, 1, 3, 13, 1, 13, 1, - 3, 7, 3, 7, 1, 9, 3, 3, 1, 7, - 1, 7, 1, 2, 2, 7, 2, 7, 2, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 2, 7, 11, 2, 7, 2, 7, 7, 7, - 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, - 7, 2, 7, 7, 2, 7, 7, 7, 7, 2, - 7, 7, 7, 7, 2, 7, 2, 7, 7, 7, - 2, 5, 5, 5, 5, 5, 5, 5, 5, 5, - 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, - 5, 5, 5, 5, 5, 2, 2, 2, 2, 2, - 2, 2, 2, 2, 5, 3, 3, 5, 7, 7, - 7, 9, 7, 9, 9, 7, 5, 5, 5, 9, - 5, 9, 5, 9, 5, 3, 5, 5, 9, 9, - 13, 13, 2, 7, 7, 7, 3, 7, 3, 7, - 3, 3, 3, 3, 13, 3, 3, 3, 2, 7, - 6, 8, 2 }; -int yychk[]={ - - -1000, -1, -2, 256, 262, -3, -4, -5, -6, -7, - -8, 283, -17, 273, 277, 276, 282, -2, 257, 363, - 256, -13, -11, -12, 257, 260, -9, -10, 257, 260, - 257, 262, -15, -18, -20, -25, -24, -26, 256, -27, - -28, -29, -30, -31, -32, -33, -34, -35, -36, -37, - 340, 280, 345, 346, 348, 309, 292, 307, 301, 297, - 310, 343, 299, 350, 305, 324, 351, 326, 353, 328, - 303, 338, 355, 342, -38, -39, -40, -41, -42, -43, - -44, -45, -46, 266, 257, 279, 263, 357, 366, 364, - 295, 258, 259, 260, 261, 272, 285, 287, 274, 265, - 291, 290, 271, 284, -14, 257, 360, 360, 362, -21, - 357, -19, -23, 275, 278, 286, 270, 363, 295, 338, - 313, 312, 317, 316, 347, 349, 308, 304, 302, 306, - 298, 300, 311, 294, 344, 325, 329, 333, 331, 323, - 315, 352, 356, 327, 337, 335, 321, 319, 354, 339, - 296, 341, 289, 345, 326, 336, 334, 320, 318, 353, - 324, 332, 330, 322, 314, 351, 328, 355, 346, 348, - 301, 307, 303, 305, 297, 299, 310, 293, 343, 342, - 340, 292, 364, 366, 357, 309, -36, -36, -36, -36, - -36, -36, -36, -36, -36, -36, -36, -36, -36, -36, - -36, -36, -36, -36, -36, -36, -36, -36, -36, -36, - -24, -25, -47, -25, -48, -25, -47, 272, 257, -25, - -25, -24, -24, -24, -24, -24, -24, -24, 360, -12, - -10, 258, 357, -16, -14, -20, -14, -24, -20, -26, - -27, -27, -27, -27, -27, -27, -27, -27, -27, -27, - -27, -27, -27, -27, -27, -27, -27, -27, -27, -27, - -27, -27, -27, -27, -27, -27, -27, -27, -27, -27, - -27, -27, -27, -29, -29, -31, -31, -31, -31, -31, - -31, -31, -31, -31, -31, -31, -31, -31, -31, -32, - -32, -33, -33, -33, -33, -34, -34, -34, -34, -34, - -36, -36, -36, -47, -24, 367, -49, -25, -47, 257, - 358, 360, 367, 363, 365, 268, 288, 281, 268, 268, - 268, 257, -22, -14, 358, 270, 363, 363, 264, 365, - -52, 362, 359, 361, 367, 360, 358, -25, -48, -24, - -24, 366, -24, -24, -24, 358, 364, -29, -24, -25, - 269, -50, -51, 267, -24, 365, 365, -24, 367, 363, - 362, 362, -51, -24, -24 }; -int yydef[]={ - - -2, -2, 0, 2, 1, 3, 4, 5, 6, 7, - 8, 0, 0, 20, 0, 0, 0, 0, 22, 34, - -2, 0, 15, 16, 18, 19, 9, 10, 12, 13, - 27, 200, 0, 38, 0, 0, 43, 44, 202, 46, - 48, 81, 84, 86, 101, 104, 109, 114, 116, 120, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, 0, 0, 0, 145, 146, 147, 148, 149, 150, - 151, 152, 153, 0, 155, 156, -2, -2, -2, -2, - 0, 190, 191, 192, 193, 175, -2, -2, 0, 0, - 0, 0, 0, 0, 21, 32, 0, 0, 0, 0, - 24, -2, 0, 0, 36, 37, 201, -2, 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, 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, 0, 0, - 0, 0, -2, -2, -2, 0, 121, 122, 123, 124, - 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, - 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, - 154, 157, 0, 186, 0, 198, 0, 166, 167, 176, - 177, 43, 0, 0, 168, 170, 172, 174, 0, 17, - 11, 14, 29, 0, 25, 0, 0, 0, 41, 45, - 47, 49, 50, 51, 52, 53, 54, 55, 56, 57, - 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, - 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, - 78, 79, 80, 82, 85, 87, 88, 89, 90, 91, - 92, 93, 94, 95, 96, 97, 98, 99, 100, 102, - 103, 105, 106, 107, 108, 110, 111, 112, 113, 115, - 117, 118, 119, 0, 43, 162, 0, 188, 0, 165, - 158, -2, 159, -2, 160, 0, 0, 0, 0, 0, - 0, 33, 0, 30, 23, 26, 35, 39, 0, 161, - 0, 195, 196, 197, 163, -2, 164, 187, 199, 178, - 179, 0, 169, 171, 173, 28, 0, 83, 0, 189, - 0, 0, 182, 0, 0, 31, 194, 180, 181, 0, - 0, 0, 183, 184, 185 }; -typedef struct { char *t_name; int t_val; } yytoktype; -#ifndef YYDEBUG -# define YYDEBUG 0 /* don't allow debugging */ -#endif - -#if YYDEBUG - -yytoktype yytoks[] = -{ - "IDENT", 257, - "INTLIT", 258, - "REALLIT", 259, - "STRINGLIT", 260, - "CSETLIT", 261, - "EOFX", 262, - "BREAK", 263, - "BY", 264, - "CASE", 265, - "CREATE", 266, - "DEFAULT", 267, - "DO", 268, - "ELSE", 269, - "END", 270, - "EVERY", 271, - "FAIL", 272, - "GLOBAL", 273, - "IF", 274, - "INITIAL", 275, - "INVOCABLE", 276, - "LINK", 277, - "LOCAL", 278, - "NEXT", 279, - "NOT", 280, - "OF", 281, - "PROCEDURE", 282, - "RECORD", 283, - "REPEAT", 284, - "RETURN", 285, - "STATIC", 286, - "SUSPEND", 287, - "THEN", 288, - "TO", 289, - "UNTIL", 290, - "WHILE", 291, - "BANG", 292, - "MOD", 293, - "AUGMOD", 294, - "AND", 295, - "AUGAND", 296, - "STAR", 297, - "AUGSTAR", 298, - "INTER", 299, - "AUGINTER", 300, - "PLUS", 301, - "AUGPLUS", 302, - "UNION", 303, - "AUGUNION", 304, - "MINUS", 305, - "AUGMINUS", 306, - "DIFF", 307, - "AUGDIFF", 308, - "DOT", 309, - "SLASH", 310, - "AUGSLASH", 311, - "ASSIGN", 312, - "SWAP", 313, - "NMLT", 314, - "AUGNMLT", 315, - "REVASSIGN", 316, - "REVSWAP", 317, - "SLT", 318, - "AUGSLT", 319, - "SLE", 320, - "AUGSLE", 321, - "NMLE", 322, - "AUGNMLE", 323, - "NMEQ", 324, - "AUGNMEQ", 325, - "SEQ", 326, - "AUGSEQ", 327, - "EQUIV", 328, - "AUGEQUIV", 329, - "NMGT", 330, - "AUGNMGT", 331, - "NMGE", 332, - "AUGNMGE", 333, - "SGT", 334, - "AUGSGT", 335, - "SGE", 336, - "AUGSGE", 337, - "QMARK", 338, - "AUGQMARK", 339, - "AT", 340, - "AUGAT", 341, - "BACKSLASH", 342, - "CARET", 343, - "AUGCARET", 344, - "BAR", 345, - "CONCAT", 346, - "AUGCONCAT", 347, - "LCONCAT", 348, - "AUGLCONCAT", 349, - "TILDE", 350, - "NMNE", 351, - "AUGNMNE", 352, - "SNE", 353, - "AUGSNE", 354, - "NEQUIV", 355, - "AUGNEQUIV", 356, - "LPAREN", 357, - "RPAREN", 358, - "PCOLON", 359, - "COMMA", 360, - "MCOLON", 361, - "COLON", 362, - "SEMICOL", 363, - "LBRACK", 364, - "RBRACK", 365, - "LBRACE", 366, - "RBRACE", 367, - "-unknown-", -1 /* ends search */ -}; - -char * yyreds[] = -{ - "-no such reduction-", - "program : decls EOFX", - "decls : /* empty */", - "decls : decls decl", - "decl : record", - "decl : proc", - "decl : global", - "decl : link", - "decl : invocable", - "invocable : INVOCABLE invoclist", - "invoclist : invocop", - "invoclist : invoclist COMMA invocop", - "invocop : IDENT", - "invocop : STRINGLIT", - "invocop : STRINGLIT COLON INTLIT", - "link : LINK lnklist", - "lnklist : lnkfile", - "lnklist : lnklist COMMA lnkfile", - "lnkfile : IDENT", - "lnkfile : STRINGLIT", - "global : GLOBAL", - "global : GLOBAL idlist", - "record : RECORD IDENT", - "record : RECORD IDENT LPAREN fldlist RPAREN", - "fldlist : /* empty */", - "fldlist : idlist", - "proc : prochead SEMICOL locals initial procbody END", - "prochead : PROCEDURE IDENT", - "prochead : PROCEDURE IDENT LPAREN arglist RPAREN", - "arglist : /* empty */", - "arglist : idlist", - "arglist : idlist LBRACK RBRACK", - "idlist : IDENT", - "idlist : idlist COMMA IDENT", - "locals : /* empty */", - "locals : locals retention idlist SEMICOL", - "retention : LOCAL", - "retention : STATIC", - "initial : /* empty */", - "initial : INITIAL expr SEMICOL", - "procbody : /* empty */", - "procbody : nexpr SEMICOL procbody", - "nexpr : /* empty */", - "nexpr : expr", - "expr : expr1a", - "expr : expr AND expr1a", - "expr1a : expr1", - "expr1a : expr1a QMARK expr1", - "expr1 : expr2", - "expr1 : expr2 SWAP expr1", - "expr1 : expr2 ASSIGN expr1", - "expr1 : expr2 REVSWAP expr1", - "expr1 : expr2 REVASSIGN expr1", - "expr1 : expr2 AUGCONCAT expr1", - "expr1 : expr2 AUGLCONCAT expr1", - "expr1 : expr2 AUGDIFF expr1", - "expr1 : expr2 AUGUNION expr1", - "expr1 : expr2 AUGPLUS expr1", - "expr1 : expr2 AUGMINUS expr1", - "expr1 : expr2 AUGSTAR expr1", - "expr1 : expr2 AUGINTER expr1", - "expr1 : expr2 AUGSLASH expr1", - "expr1 : expr2 AUGMOD expr1", - "expr1 : expr2 AUGCARET expr1", - "expr1 : expr2 AUGNMEQ expr1", - "expr1 : expr2 AUGEQUIV expr1", - "expr1 : expr2 AUGNMGE expr1", - "expr1 : expr2 AUGNMGT expr1", - "expr1 : expr2 AUGNMLE expr1", - "expr1 : expr2 AUGNMLT expr1", - "expr1 : expr2 AUGNMNE expr1", - "expr1 : expr2 AUGNEQUIV expr1", - "expr1 : expr2 AUGSEQ expr1", - "expr1 : expr2 AUGSGE expr1", - "expr1 : expr2 AUGSGT expr1", - "expr1 : expr2 AUGSLE expr1", - "expr1 : expr2 AUGSLT expr1", - "expr1 : expr2 AUGSNE expr1", - "expr1 : expr2 AUGQMARK expr1", - "expr1 : expr2 AUGAND expr1", - "expr1 : expr2 AUGAT expr1", - "expr2 : expr3", - "expr2 : expr2 TO expr3", - "expr2 : expr2 TO expr3 BY expr3", - "expr3 : expr4", - "expr3 : expr4 BAR expr3", - "expr4 : expr5", - "expr4 : expr4 SEQ expr5", - "expr4 : expr4 SGE expr5", - "expr4 : expr4 SGT expr5", - "expr4 : expr4 SLE expr5", - "expr4 : expr4 SLT expr5", - "expr4 : expr4 SNE expr5", - "expr4 : expr4 NMEQ expr5", - "expr4 : expr4 NMGE expr5", - "expr4 : expr4 NMGT expr5", - "expr4 : expr4 NMLE expr5", - "expr4 : expr4 NMLT expr5", - "expr4 : expr4 NMNE expr5", - "expr4 : expr4 EQUIV expr5", - "expr4 : expr4 NEQUIV expr5", - "expr5 : expr6", - "expr5 : expr5 CONCAT expr6", - "expr5 : expr5 LCONCAT expr6", - "expr6 : expr7", - "expr6 : expr6 PLUS expr7", - "expr6 : expr6 DIFF expr7", - "expr6 : expr6 UNION expr7", - "expr6 : expr6 MINUS expr7", - "expr7 : expr8", - "expr7 : expr7 STAR expr8", - "expr7 : expr7 INTER expr8", - "expr7 : expr7 SLASH expr8", - "expr7 : expr7 MOD expr8", - "expr8 : expr9", - "expr8 : expr9 CARET expr8", - "expr9 : expr10", - "expr9 : expr9 BACKSLASH expr10", - "expr9 : expr9 AT expr10", - "expr9 : expr9 BANG expr10", - "expr10 : expr11", - "expr10 : AT expr10", - "expr10 : NOT expr10", - "expr10 : BAR expr10", - "expr10 : CONCAT expr10", - "expr10 : LCONCAT expr10", - "expr10 : DOT expr10", - "expr10 : BANG expr10", - "expr10 : DIFF expr10", - "expr10 : PLUS expr10", - "expr10 : STAR expr10", - "expr10 : SLASH expr10", - "expr10 : CARET expr10", - "expr10 : INTER expr10", - "expr10 : TILDE expr10", - "expr10 : MINUS expr10", - "expr10 : NMEQ expr10", - "expr10 : NMNE expr10", - "expr10 : SEQ expr10", - "expr10 : SNE expr10", - "expr10 : EQUIV expr10", - "expr10 : UNION expr10", - "expr10 : QMARK expr10", - "expr10 : NEQUIV expr10", - "expr10 : BACKSLASH expr10", - "expr11 : literal", - "expr11 : section", - "expr11 : return", - "expr11 : if", - "expr11 : case", - "expr11 : while", - "expr11 : until", - "expr11 : every", - "expr11 : repeat", - "expr11 : CREATE expr", - "expr11 : IDENT", - "expr11 : NEXT", - "expr11 : BREAK nexpr", - "expr11 : LPAREN exprlist RPAREN", - "expr11 : LBRACE compound RBRACE", - "expr11 : LBRACK exprlist RBRACK", - "expr11 : expr11 LBRACK exprlist RBRACK", - "expr11 : expr11 LBRACE RBRACE", - "expr11 : expr11 LBRACE pdcolist RBRACE", - "expr11 : expr11 LPAREN exprlist RPAREN", - "expr11 : expr11 DOT IDENT", - "expr11 : AND FAIL", - "expr11 : AND IDENT", - "while : WHILE expr", - "while : WHILE expr DO expr", - "until : UNTIL expr", - "until : UNTIL expr DO expr", - "every : EVERY expr", - "every : EVERY expr DO expr", - "repeat : REPEAT expr", - "return : FAIL", - "return : RETURN nexpr", - "return : SUSPEND nexpr", - "return : SUSPEND expr DO expr", - "if : IF expr THEN expr", - "if : IF expr THEN expr ELSE expr", - "case : CASE expr OF LBRACE caselist RBRACE", - "caselist : cclause", - "caselist : caselist SEMICOL cclause", - "cclause : DEFAULT COLON expr", - "cclause : expr COLON expr", - "exprlist : nexpr", - "exprlist : exprlist COMMA nexpr", - "pdcolist : nexpr", - "pdcolist : pdcolist COMMA nexpr", - "literal : INTLIT", - "literal : REALLIT", - "literal : STRINGLIT", - "literal : CSETLIT", - "section : expr11 LBRACK expr sectop expr RBRACK", - "sectop : COLON", - "sectop : PCOLON", - "sectop : MCOLON", - "compound : nexpr", - "compound : nexpr SEMICOL compound", - "program : error decls EOFX", - "proc : prochead error procbody END", - "expr : error", -}; -#endif -#line 1 "/usr/lib/yaccpar" -/* @(#)yaccpar 1.10 89/04/04 SMI; from S5R3 1.10 */ - -/* -** Skeleton parser driver for yacc output -*/ - -/* -** yacc user known macros and defines -*/ -#define YYERROR goto yyerrlab -#define YYACCEPT { free(yys); free(yyv); return(0); } -#define YYABORT { free(yys); free(yyv); return(1); } -#define YYBACKUP( newtoken, newvalue )\ -{\ - if ( yychar >= 0 || ( yyr2[ yytmp ] >> 1 ) != 1 )\ - {\ - tsyserr("parser: 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) - -/* -** static variables used by the parser -*/ -static YYSTYPE *yyv; /* value stack */ -static int *yys; /* state stack */ - -static YYSTYPE *yypv; /* top of value stack */ -static int *yyps; /* top of state stack */ - -static int yystate; /* current state */ -static 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 */ - unsigned yymaxdepth = YYMAXDEPTH; - - /* - ** Initialize externals - yyparse may be called more than once - */ - yyv = (YYSTYPE*)malloc(yymaxdepth*sizeof(YYSTYPE)); - yys = (int*)malloc(yymaxdepth*sizeof(int)); - if (!yyv || !yys) - { - tsyserr("parser: out of memory" ); - return(1); - } - 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; - - (void)printf( "State %d, token ", yy_state ); - if ( yychar == 0 ) - (void)printf( "end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "-none-\n" ); - else - { - for ( yy_i = 0; yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val == yychar ) - break; - } - (void)printf( "%s\n", yytoks[yy_i].t_name ); - } - } -#endif - if ( ++yy_ps >= &yys[ yymaxdepth ] ) /* room on stack? */ - { - /* - ** reallocate and recover. Note that pointers - ** have to be reset, or bad things will happen - */ - int yyps_index = (yy_ps - yys); - int yypv_index = (yy_pv - yyv); - int yypvt_index = (yypvt - yyv); - yymaxdepth += YYMAXDEPTH; - yyv = (YYSTYPE*)realloc((char*)yyv, - yymaxdepth * sizeof(YYSTYPE)); - yys = (int*)realloc((char*)yys, - yymaxdepth * sizeof(int)); - if (!yyv || !yys) - { - tsyserr("parse stack overflow" ); - return(1); - } - yy_ps = yys + yyps_index; - yy_pv = yyv + yypv_index; - yypvt = yyv + yypvt_index; - } - *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; - - (void)printf( "Received token " ); - if ( yychar == 0 ) - (void)printf( "end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "-none-\n" ); - else - { - for ( yy_i = 0; yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val == yychar ) - break; - } - (void)printf( "%s\n", yytoks[yy_i].t_name ); - } - } -#endif - 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; - - (void)printf( "Received token " ); - if ( yychar == 0 ) - (void)printf( "end-of-file\n" ); - else if ( yychar < 0 ) - (void)printf( "-none-\n" ); - else - { - for ( yy_i = 0; - yytoks[yy_i].t_val >= 0; - yy_i++ ) - { - if ( yytoks[yy_i].t_val - == yychar ) - { - break; - } - } - (void)printf( "%s\n", yytoks[yy_i].t_name ); - } - } -#endif - /* - ** 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(yychar, yylval, yy_state ); - 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 ) - (void)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; - - (void)printf( "Error recovery discards " ); - if ( yychar == 0 ) - (void)printf( "token end-of-file\n" ); - else if ( yychar < 0 ) - (void)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; - } - } - (void)printf( "token %s\n", - yytoks[yy_i].t_name ); - } - } -#endif - 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 ) - (void)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 1: -# line 177 "cgram.g" -{;} break; -case 4: -# line 182 "cgram.g" -{;} break; -case 5: -# line 183 "cgram.g" -{proc_lst->tree = yypvt[-0] ;} break; -case 6: -# line 184 "cgram.g" -{;} break; -case 7: -# line 185 "cgram.g" -{;} break; -case 8: -# line 186 "cgram.g" -{;} break; -case 9: -# line 188 "cgram.g" -{;} break; -case 11: -# line 191 "cgram.g" -{;} break; -case 12: -# line 193 "cgram.g" -{invoc_grp(Str0(yypvt[-0])); ;} break; -case 13: -# line 194 "cgram.g" -{invocbl(yypvt[-0], -1); ;} break; -case 14: -# line 195 "cgram.g" -{invocbl(yypvt[-2], atoi(Str0(yypvt[-0]))); ;} break; -case 15: -# line 197 "cgram.g" -{;} break; -case 17: -# line 200 "cgram.g" -{;} break; -case 18: -# line 202 "cgram.g" -{lnkdcl(Str0(yypvt[-0])); ;} break; -case 19: -# line 203 "cgram.g" -{lnkdcl(Str0(yypvt[-0])); ;} break; -case 20: -# line 205 "cgram.g" -{idflag = F_Global ;} break; -case 21: -# line 205 "cgram.g" -{;} break; -case 22: -# line 207 "cgram.g" -{init_rec(Str0(yypvt[-0])); idflag = F_Field ;} break; -case 23: -# line 207 "cgram.g" -{ - ; - } break; -case 24: -# line 211 "cgram.g" -{;} break; -case 25: -# line 212 "cgram.g" -{;} break; -case 26: -# line 214 "cgram.g" -{ - yyval = tree6(N_Proc,yypvt[-5],yypvt[-5],yypvt[-2],yypvt[-1],yypvt[-0]) ; - } break; -case 27: -# line 218 "cgram.g" -{init_proc(Str0(yypvt[-0])); idflag = F_Argument ;} break; -case 28: -# line 218 "cgram.g" -{ - ; - } break; -case 29: -# line 222 "cgram.g" -{;} break; -case 30: -# line 223 "cgram.g" -{;} break; -case 31: -# line 224 "cgram.g" -{proc_lst->nargs = -proc_lst->nargs ;} break; -case 32: -# line 227 "cgram.g" -{ - install(Str0(yypvt[-0]),idflag) ; - } break; -case 33: -# line 230 "cgram.g" -{ - install(Str0(yypvt[-0]),idflag) ; - } break; -case 34: -# line 234 "cgram.g" -{;} break; -case 35: -# line 235 "cgram.g" -{;} break; -case 36: -# line 237 "cgram.g" -{idflag = F_Dynamic ;} break; -case 37: -# line 238 "cgram.g" -{idflag = F_Static ;} break; -case 38: -# line 240 "cgram.g" -{yyval = tree1(N_Empty) ;} break; -case 39: -# line 241 "cgram.g" -{yyval = yypvt[-1] ;} break; -case 40: -# line 243 "cgram.g" -{yyval = tree1(N_Empty) ;} break; -case 41: -# line 244 "cgram.g" -{yyval = tree4(N_Slist,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 42: -# line 246 "cgram.g" -{yyval = tree1(N_Empty) ;} break; -case 45: -# line 250 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 47: -# line 253 "cgram.g" -{yyval = tree5(N_Scan,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 49: -# line 256 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 50: -# line 257 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 51: -# line 258 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 52: -# line 259 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 53: -# line 260 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 54: -# line 261 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 55: -# line 262 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 56: -# line 263 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 57: -# line 264 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 58: -# line 265 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 59: -# line 266 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 60: -# line 267 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 61: -# line 268 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 62: -# line 269 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 63: -# line 270 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 64: -# line 271 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 65: -# line 272 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 66: -# line 273 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 67: -# line 274 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 68: -# line 275 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 69: -# line 276 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 70: -# line 277 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 71: -# line 278 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 72: -# line 279 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 73: -# line 280 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 74: -# line 281 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 75: -# line 282 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 76: -# line 283 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 77: -# line 284 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 78: -# line 285 "cgram.g" -{yyval = tree5(N_Scan,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 79: -# line 286 "cgram.g" -{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 80: -# line 287 "cgram.g" -{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 82: -# line 290 "cgram.g" -{yyval = to_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 83: -# line 291 "cgram.g" -{yyval = toby_nd(yypvt[-3],yypvt[-4],yypvt[-2],yypvt[-0]) ;} break; -case 85: -# line 294 "cgram.g" -{yyval = tree4(N_Alt,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 87: -# line 297 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 88: -# line 298 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 89: -# line 299 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 90: -# line 300 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 91: -# line 301 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 92: -# line 302 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 93: -# line 303 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 94: -# line 304 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 95: -# line 305 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 96: -# line 306 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 97: -# line 307 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 98: -# line 308 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 99: -# line 309 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 100: -# line 310 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 102: -# line 313 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 103: -# line 314 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 105: -# line 317 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 106: -# line 318 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 107: -# line 319 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 108: -# line 320 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 110: -# line 323 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 111: -# line 324 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 112: -# line 325 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 113: -# line 326 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 115: -# line 329 "cgram.g" -{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 117: -# line 332 "cgram.g" -{yyval = tree4(N_Limit,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 118: -# line 333 "cgram.g" -{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 119: -# line 334 "cgram.g" -{yyval = tree4(N_Apply,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 121: -# line 337 "cgram.g" -{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],tree1(N_Empty) ,yypvt[-0]) ;} break; -case 122: -# line 338 "cgram.g" -{yyval = tree3(N_Not,yypvt[-0],yypvt[-0]) ;} break; -case 123: -# line 339 "cgram.g" -{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]) ;} break; -case 124: -# line 340 "cgram.g" -{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]) ;} break; -case 125: -# line 341 "cgram.g" -{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]) ;} break; -case 126: -# line 342 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 127: -# line 343 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 128: -# line 344 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 129: -# line 345 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 130: -# line 346 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 131: -# line 347 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 132: -# line 348 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 133: -# line 349 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 134: -# line 350 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 135: -# line 351 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 136: -# line 352 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 137: -# line 353 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 138: -# line 354 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 139: -# line 355 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 140: -# line 356 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 141: -# line 357 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 142: -# line 358 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 143: -# line 359 "cgram.g" -{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; -case 144: -# line 360 "cgram.g" -{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; -case 154: -# line 371 "cgram.g" -{yyval = tree3(N_Create,yypvt[-1],yypvt[-0]); proc_lst->has_coexpr = 1; ;} break; -case 155: -# line 372 "cgram.g" -{LSym0(yypvt[-0]) = putloc(Str0(yypvt[-0]),0) ;} break; -case 156: -# line 373 "cgram.g" -{yyval = tree2(N_Next,yypvt[-0]) ;} break; -case 157: -# line 374 "cgram.g" -{yyval = tree3(N_Break,yypvt[-1],yypvt[-0]) ;} break; -case 158: -# line 375 "cgram.g" -{if ((yypvt[-1])->n_type == N_Elist) yyval = invk_nd(yypvt[-2],tree1(N_Empty) ,yypvt[-1]); else yyval = yypvt[-1] ;} break; -case 159: -# line 376 "cgram.g" -{yyval = yypvt[-1] ;} break; -case 160: -# line 377 "cgram.g" -{yyval = list_nd(yypvt[-2],yypvt[-1]) ;} break; -case 161: -# line 378 "cgram.g" -{yyval = buildarray(yypvt[-3],yypvt[-2],yypvt[-1]) ;} break; -case 162: -# line 379 "cgram.g" -{yyval = invk_nd(yypvt[-1],yypvt[-2],list_nd(yypvt[-1],tree1(N_Empty) )) ;} break; -case 163: -# line 380 "cgram.g" -{yyval = invk_nd(yypvt[-2],yypvt[-3],list_nd(yypvt[-2],yypvt[-1])) ;} break; -case 164: -# line 381 "cgram.g" -{yyval = invk_nd(yypvt[-2],yypvt[-3],yypvt[-1]) ;} break; -case 165: -# line 382 "cgram.g" -{yyval = tree4(N_Field,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 166: -# line 383 "cgram.g" -{yyval = key_leaf(yypvt[-1],spec_str("fail")) ;} break; -case 167: -# line 384 "cgram.g" -{yyval = key_leaf(yypvt[-1],Str0(yypvt[-0])) ;} break; -case 168: -# line 386 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; -case 169: -# line 387 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; -case 170: -# line 389 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; -case 171: -# line 390 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; -case 172: -# line 392 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; -case 173: -# line 393 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; -case 174: -# line 395 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; -case 175: -# line 397 "cgram.g" -{yyval = tree4(N_Ret,yypvt[-0],yypvt[-0],tree1(N_Empty) ) ;} break; -case 176: -# line 398 "cgram.g" -{yyval = tree4(N_Ret,yypvt[-1],yypvt[-1],yypvt[-0]) ;} break; -case 177: -# line 399 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; -case 178: -# line 400 "cgram.g" -{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; -case 179: -# line 402 "cgram.g" -{yyval = tree5(N_If,yypvt[-3],yypvt[-2],yypvt[-0],tree1(N_Empty) ) ;} break; -case 180: -# line 403 "cgram.g" -{yyval = tree5(N_If,yypvt[-5],yypvt[-4],yypvt[-2],yypvt[-0]) ;} break; -case 181: -# line 405 "cgram.g" -{yyval = case_nd(yypvt[-5],yypvt[-4],yypvt[-1]) ;} break; -case 183: -# line 408 "cgram.g" -{yyval = tree4(N_Clist,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 184: -# line 410 "cgram.g" -{yyval = tree4(N_Ccls,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 185: -# line 411 "cgram.g" -{yyval = tree4(N_Ccls,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; -case 186: -# line 413 "cgram.g" -{yyval = yypvt[-0]; ;} break; -case 187: -# line 414 "cgram.g" -{yyval = tree4(N_Elist,yypvt[-1],yypvt[-2],yypvt[-0]); ;} break; -case 188: -# line 416 "cgram.g" -{ - yyval = tree3(N_Create,yypvt[-0],yypvt[-0]); proc_lst->has_coexpr = 1; ; - } break; -case 189: -# line 419 "cgram.g" -{ - yyval =tree4(N_Elist,yypvt[-1],yypvt[-2],tree3(N_Create,yypvt[-1],yypvt[-0])); proc_lst->has_coexpr = 1; ; - } break; -case 190: -# line 423 "cgram.g" -{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_IntLit,0) ;} break; -case 191: -# line 424 "cgram.g" -{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_RealLit,0) ;} break; -case 192: -# line 425 "cgram.g" -{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_StrLit,(int)Val1(yypvt[-0])) ;} break; -case 193: -# line 426 "cgram.g" -{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_CsetLit,(int)Val1(yypvt[-0])) ;} break; -case 194: -# line 428 "cgram.g" -{yyval = sect_nd(yypvt[-2],yypvt[-5],yypvt[-3],yypvt[-1]) ;} break; -case 195: -# line 430 "cgram.g" -{yyval = yypvt[-0] ;} break; -case 196: -# line 431 "cgram.g" -{yyval = yypvt[-0] ;} break; -case 197: -# line 432 "cgram.g" -{yyval = yypvt[-0] ;} break; -case 199: -# line 435 "cgram.g" -{yyval = tree4(N_Slist,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; - } - goto yystack; /* reset registers in driver code */ -} diff --git a/src/iconc/cproto.h b/src/iconc/cproto.h deleted file mode 100644 index a32b982..0000000 --- a/src/iconc/cproto.h +++ /dev/null @@ -1,165 +0,0 @@ -/* - * Prototypes for functions in iconc. - */ -struct sig_lst *add_sig (struct code *sig, struct c_fnc *fnc); -void addlib (char *libname); -struct code *alc_ary (int n); -int alc_cbufs (int num, nodeptr lifetime); -int alc_dtmp (nodeptr lifetime); -int alc_itmp (nodeptr lifetime); -struct code *alc_lbl (char *desc, int flag); -int alc_sbufs (int num, nodeptr lifetime); -#ifdef OptimizeType -unsigned int *alloc_mem_typ (unsigned int n_types); -#endif /* OptimizeType */ -void arth_anlz (struct il_code *var1, struct il_code *var2, - int *maybe_int, int *maybe_dbl, int *chk1, - struct code **conv1p, int *chk2, - struct code **conv2p); -struct node *aug_nd (nodeptr op, nodeptr arg1, nodeptr arg2); -struct node *binary_nd (nodeptr op, nodeptr arg1, nodeptr arg2); -void bitrange (int typcd, int *frst_bit, int *last_bit); -nodeptr buildarray (nodeptr a, nodeptr lb, nodeptr e); -void callc_add (struct c_fnc *cont); -void callo_add (char *oper_nm, int ret_flag, - struct c_fnc *cont, int need_cont, - struct code *arglist, struct code *on_ret); -struct node *case_nd (nodeptr loc_model, nodeptr expr, nodeptr cases); -int ccomp (char *srcname, char *exename); -void cd_add (struct code *cd); -struct val_loc *chk_alc (struct val_loc *rslt, nodeptr lifetime); -void chkinv (void); -void chkstrinv (void); -struct node *c_str_leaf (int type,struct node *loc_model, char *c); -void codegen (struct node *t); -int cond_anlz (struct il_code *il, struct code **cdp); -void const_blks (void); -struct val_loc *cvar_loc (char *name); -int do_inlin (struct implement *impl, nodeptr n, int *sep_cont, - struct op_symentry *symtab, int n_va); -void doiconx (char *s); -struct val_loc *dtmp_loc (int n); -void eval_arith (int indx1, int indx2, int *maybe_int, int *maybe_dbl); -int eval_cnv (int typcd, int indx, int def, int *cnv_flags); -int eval_is (int typcd,int indx); -void findcases (struct il_code *il, int has_dflt, - struct case_anlz *case_anlz); -void fix_fncs (struct c_fnc *fnc); -struct fentry *flookup (char *id); -void gen_inlin (struct il_code *il, struct val_loc *rslt, - struct code **scont_strt, - struct code **scont_fail, struct c_fnc *cont, - struct implement *impl, int nsyms, - struct op_symentry *symtab, nodeptr n, - int dcl_var, int n_va); -int getopr (int ac, int *cc); -#ifdef OptimizeType -unsigned int get_bit_vector (struct typinfo *src, int pos); -#endif /* OptimizeType */ -struct gentry *glookup (char *id); -void hsyserr (char **av, char *file); -struct node *i_str_leaf (int type,struct node *loc_model,char *c, int d); -long iconint (char *image); -struct code *il_copy (struct il_c *dest, struct val_loc *src); -struct code *il_cnv (int typcd, struct il_code *src, - struct il_c *dflt, struct il_c *dest); -struct code *il_dflt (int typcd, struct il_code *src, - struct il_c *dflt, struct il_c *dest); -void implproto (struct implement *ip); -void init (void); -void init_proc (char *name); -void init_rec (char *name); -void init_src (void); -void install (char *name,int flag); -struct gentry *instl_p (char *name, int flag); -struct node *int_leaf (int type,struct node *loc_model,int c); -struct val_loc *itmp_loc (int n); -struct node *invk_main (struct pentry *main_proc); -struct node *invk_nd (struct node *loc_model, struct node *proc, - struct node *args); -void invoc_grp (char *grp); -void invocbl (nodeptr op, int arity); -struct node *key_leaf (nodeptr loc_model, char *keyname); -void liveness (nodeptr n, nodeptr resumer, nodeptr *failer, int *gen); -struct node *list_nd (nodeptr loc_model, nodeptr args); -void lnkdcl (char *name); -void readdb (char *db_name); -struct val_loc *loc_cpy (struct val_loc *loc, int mod_access); -#ifdef OptimizeType -void mark_recs (struct fentry *fp, struct typinfo *typ, - int *num_offsets, int *offset, int *bad_recs); -#else /* OptimizeType */ -void mark_recs (struct fentry *fp, unsigned int *typ, - int *num_offsets, int *offset, int *bad_recs); -#endif /* OptimizeType */ -struct code *mk_goto (struct code *label); -struct node *multiunary (char *op, nodeptr loc_model, nodeptr oprnd); -struct sig_act *new_sgact (struct code *sig, struct code *cd, - struct sig_act *next); -int nextchar (void); -void nfatal (struct node *n, char *s1, char *s2); -int n_arg_sym (struct implement *ip); -void outerfnc (struct c_fnc *fnc); -int past_prms (struct node *n); -void proccode (struct pentry *proc); -void prt_fnc (struct c_fnc *fnc); -void prt_frame (char *prefix, int ntend, int n_itmp, - int i, int j, int k); -struct centry *putlit (char *image,int littype,int len); -struct lentry *putloc (char *id,int id_type); -void quit (char *msg); -void quitf (char *msg,char *arg); -void recconstr (struct rentry *r); -void resolve (struct pentry *proc); -unsigned int round2 (unsigned int n); -struct code *sig_cd (struct code *fail, struct c_fnc *fnc); -void src_file (char *name); -struct node *sect_nd (nodeptr op, nodeptr arg1, nodeptr arg2, - nodeptr arg3); -void tfatal (char *s1,char *s2); -struct node *to_nd (nodeptr loc_model, nodeptr arg1, - nodeptr arg2); -struct node *toby_nd (nodeptr loc_model, nodeptr arg1, - nodeptr arg2, nodeptr arg3); -int trans (void); -struct node *tree1 (int type); -struct node *tree2 (int type,struct node *loc_model); -struct node *tree3 (int type,struct node *loc_model, - struct node *c); -struct node *tree4 (int type, struct node *loc_model, - struct node *c, struct node *d); -struct node *tree5 (int type, struct node *loc_model, - struct node *c, struct node *d, - struct node *e); -struct node *tree6 (int type,struct node *loc_model, - struct node *c, struct node *d, - struct node *e, struct node *f); -void tsyserr (char *s); -void twarn (char *s1,char *s2); -struct code *typ_chk (struct il_code *var, int typcd); -int type_case (struct il_code *il, int (*fnc)(), - struct case_anlz *case_anlz); -void typeinfer (void); -struct node *unary_nd (nodeptr op, nodeptr arg); -void var_dcls (void); -#ifdef OptimizeType -int varsubtyp (struct typinfo *typ, struct lentry **single); -#else /* OptimizeType */ -int varsubtyp (unsigned int *typ, struct lentry **single); -#endif /* OptimizeType */ -void writecheck (int rc); -void yyerror (int tok,struct node *lval,int state); -int yylex (void); -int yyparse (void); -#ifdef OptimizeType -void xfer_packed_types (struct typinfo *type); -#endif /* OptimizeType */ - -#ifdef DeBug -void symdump (void); -void ldump (struct lentry **lhash); -void gdump (void); -void cdump (void); -void fdump (void); -void rdump (void); -#endif /* DeBug */ diff --git a/src/iconc/csym.c b/src/iconc/csym.c deleted file mode 100644 index 8e764e3..0000000 --- a/src/iconc/csym.c +++ /dev/null @@ -1,853 +0,0 @@ -/* - * csym.c -- functions for symbol table management. - */ -#include "../h/gsupport.h" -#include "cglobals.h" -#include "ctrans.h" -#include "ctree.h" -#include "ctoken.h" -#include "csym.h" -#include "ccode.h" -#include "cproto.h" - -/* - * Prototypes. - */ - -static struct gentry *alcglob (struct gentry *blink, - char *name,int flag); -static struct fentry *alcfld (struct fentry *blink, char *name, - struct par_rec *rp); -static struct centry *alclit (struct centry *blink, - char *image, int len,int flag); -static struct lentry *alcloc (struct lentry *blink, - char *name,int flag); -static struct par_rec *alcprec (struct rentry *rec, int offset, - struct par_rec *next); -static struct centry *clookup (char *image,int flag); -static struct lentry *dcl_loc (char *id, int id_type, - struct lentry *next); -static struct lentry *llookup (char *id); -static void opstrinv (struct implement *ip); -static struct gentry *putglob (char *id,int id_type); -static struct gentry *try_gbl (char *id); - -int max_sym = 0; /* max number of parameter symbols in run-time routines */ -int max_prm = 0; /* max number of parameters for any invocable routine */ - -/* - * The operands of the invocable declaration are stored in a list for - * later processing. - */ -struct strinv { - nodeptr op; - int arity; - struct strinv *next; - }; -struct strinv *strinvlst = NULL; -int op_tbl_sz; - -struct pentry *proc_lst = NULL; /* procedure list */ -struct rentry *rec_lst = NULL; /* record list */ - - -/* - *instl_p - install procedure or record in global symbol table, returning - * the symbol table entry. - */ -struct gentry *instl_p(name, flag) -char *name; -int flag; - { - struct gentry *gp; - - flag |= F_Global; - if ((gp = glookup(name)) == NULL) - gp = putglob(name, flag); - else if ((gp->flag & (~F_Global)) == 0) { - /* - * superfluous global declaration for record or proc - */ - gp->flag |= flag; - } - else /* the user can't make up his mind */ - tfatal("inconsistent redeclaration", name); - return gp; - } - -/* - * install - put an identifier into the global or local symbol table. - * The basic idea here is to look in the right table and install - * the identifier if it isn't already there. Some semantic checks - * are performed. - */ -void install(name, flag) -char *name; -int flag; - { - struct fentry *fp; - struct gentry *gp; - struct lentry *lp; - struct par_rec **rpp; - struct fldname *fnp; - int foffset; - - switch (flag) { - case F_Global: /* a variable in a global declaration */ - if ((gp = glookup(name)) == NULL) - putglob(name, flag); - else - gp->flag |= flag; - break; - - case F_Static: /* static declaration */ - ++proc_lst->nstatic; - lp = dcl_loc(name, flag, proc_lst->statics); - proc_lst->statics = lp; - break; - - case F_Dynamic: /* local declaration */ - ++proc_lst->ndynam; - lp = dcl_loc(name, flag, proc_lst->dynams); - proc_lst->dynams = lp; - break; - - case F_Argument: /* formal parameter */ - ++proc_lst->nargs; - if (proc_lst->nargs > max_prm) - max_prm = proc_lst->nargs; - lp = dcl_loc(name, flag, proc_lst->args); - proc_lst->args = lp; - break; - - case F_Field: /* field declaration */ - fnp = NewStruct(fldname); - fnp->name = name; - fnp->next = rec_lst->fields; - rec_lst->fields = fnp; - foffset = rec_lst->nfields++; - if (foffset > max_prm) - max_prm = foffset; - if ((fp = flookup(name)) == NULL) { - /* - * first occurrence of this field name. - */ - fhash[FHasher(name)] = alcfld(fhash[FHasher(name)], name, - alcprec(rec_lst, foffset, NULL)); - } - else { - rpp = &(fp->rlist); - while (*rpp != NULL && (*rpp)->offset <= foffset && - (*rpp)->rec != rec_lst) - rpp = &((*rpp)->next); - if (*rpp == NULL || (*rpp)->offset > foffset) - *rpp = alcprec(rec_lst, foffset, *rpp); - else - tfatal("duplicate field name", name); - } - break; - - default: - tsyserr("install: unrecognized symbol table flag."); - } - } - -/* - * dcl_loc - handle declaration of a local identifier. - */ -static struct lentry *dcl_loc(name, flag, next) -char *name; -int flag; -struct lentry *next; - { - register struct lentry *lp; - - if ((lp = llookup(name)) == NULL) { - lp = putloc(name,flag); - lp->next = next; - } - else if (lp->flag == flag) /* previously declared as same type */ - twarn("redeclared identifier", name); - else /* previously declared as different type */ - tfatal("inconsistent redeclaration", name); - return lp; - } - -/* - * putloc - make a local symbol table entry and return pointer to it. - */ -struct lentry *putloc(id,id_type) -char *id; -int id_type; - { - register struct lentry *ptr; - register struct lentry **lhash; - unsigned hashval; - - if ((ptr = llookup(id)) == NULL) { /* add to head of hash chain */ - lhash = proc_lst->lhash; - hashval = LHasher(id); - ptr = alcloc(lhash[hashval], id, id_type); - lhash[hashval] = ptr; - ptr->next = NULL; - } - return ptr; - } - -/* - * putglob makes a global symbol table entry and returns a pointer to it. - */ -static struct gentry *putglob(id, id_type) -char *id; -int id_type; - { - register struct gentry *ptr; - register unsigned hashval; - - if ((ptr = glookup(id)) == NULL) { /* add to head of hash chain */ - hashval = GHasher(id); - ptr = alcglob(ghash[hashval], id, id_type); - ghash[hashval] = ptr; - } - return ptr; - } - -/* - * putlit makes a constant symbol table entry and returns a pointer to it. - */ -struct centry *putlit(image, littype, len) -char *image; -int len, littype; - { - register struct centry *ptr; - register unsigned hashval; - - if ((ptr = clookup(image,littype)) == NULL) { /* add to head of hash chain */ - hashval = CHasher(image); - ptr = alclit(chash[hashval], image, len, littype); - chash[hashval] = ptr; - } - return ptr; - } - -/* - * llookup looks up id in local symbol table and returns pointer to - * to it if found or NULL if not present. - */ - -static struct lentry *llookup(id) -char *id; - { - register struct lentry *ptr; - - ptr = proc_lst->lhash[LHasher(id)]; - while (ptr != NULL && ptr->name != id) - ptr = ptr->blink; - return ptr; - } - -/* - * flookup looks up id in flobal symbol table and returns pointer to - * to it if found or NULL if not present. - */ -struct fentry *flookup(id) -char *id; - { - register struct fentry *ptr; - - ptr = fhash[FHasher(id)]; - while (ptr != NULL && ptr->name != id) { - ptr = ptr->blink; - } - return ptr; - } - -/* - * glookup looks up id in global symbol table and returns pointer to - * to it if found or NULL if not present. - */ -struct gentry *glookup(id) -char *id; - { - register struct gentry *ptr; - - ptr = ghash[GHasher(id)]; - while (ptr != NULL && ptr->name != id) { - ptr = ptr->blink; - } - return ptr; - } - -/* - * clookup looks up id in constant symbol table and returns pointer to - * to it if found or NULL if not present. - */ -static struct centry *clookup(image,flag) -char *image; -int flag; - { - register struct centry *ptr; - - ptr = chash[CHasher(image)]; - while (ptr != NULL && (ptr->image != image || ptr->flag != flag)) - ptr = ptr->blink; - - return ptr; - } - -#ifdef DeBug -/* - * symdump - dump symbol tables. - */ -void symdump() - { - struct pentry *proc; - - gdump(); - cdump(); - rdump(); - fdump(); - for (proc = proc_lst; proc != NULL; proc = proc->next) { - fprintf(stderr,"\n"); - fprintf(stderr,"Procedure %s\n", proc->sym_entry->name); - ldump(proc->lhash); - } - } - -/* - * prt_flgs - print flags from a symbol table entry. - */ -static void prt_flgs(flags) -int flags; - { - if (flags & F_Global) - fprintf(stderr, " F_Global"); - if (flags & F_Proc) - fprintf(stderr, " F_Proc"); - if (flags & F_Record) - fprintf(stderr, " F_Record"); - if (flags & F_Dynamic) - fprintf(stderr, " F_Dynamic"); - if (flags & F_Static) - fprintf(stderr, " F_Static"); - if (flags & F_Builtin) - fprintf(stderr, " F_Builtin"); - if (flags & F_StrInv) - fprintf(stderr, " F_StrInv"); - if (flags & F_ImpError) - fprintf(stderr, " F_ImpError"); - if (flags & F_Argument) - fprintf(stderr, " F_Argument"); - if (flags & F_IntLit) - fprintf(stderr, " F_IntLit"); - if (flags & F_RealLit) - fprintf(stderr, " F_RealLit"); - if (flags & F_StrLit) - fprintf(stderr, " F_StrLit"); - if (flags & F_CsetLit) - fprintf(stderr, " F_CsetLit"); - if (flags & F_Field) - fprintf(stderr, " F_Field"); - fprintf(stderr, "\n"); - } -/* - * ldump displays local symbol table to stderr. - */ - -void ldump(lhash) -struct lentry **lhash; - { - register int i; - register struct lentry *lptr; - - fprintf(stderr," Dump of local symbol table\n"); - fprintf(stderr," address name globol-ref flags\n"); - for (i = 0; i < LHSize; i++) - for (lptr = lhash[i]; lptr != NULL; lptr = lptr->blink) { - fprintf(stderr," %8x %20s ", lptr, lptr->name); - if (lptr->flag & F_Global) - fprintf(stderr, "%8x ", lptr->val.global); - else - fprintf(stderr, " - "); - prt_flgs(lptr->flag); - } - fflush(stderr); - } - -/* - * gdump displays global symbol table to stderr. - */ - -void gdump() - { - register int i; - register struct gentry *gptr; - - fprintf(stderr,"\n"); - fprintf(stderr,"Dump of global symbol table\n"); - fprintf(stderr," address name nargs flags\n"); - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { - fprintf(stderr," %8x %20s %4d ", gptr, - gptr->name, gptr->nargs); - prt_flgs(gptr->flag); - } - fflush(stderr); - } - -/* - * cdump displays constant symbol table to stderr. - */ - -void cdump() - { - register int i; - register struct centry *cptr; - - fprintf(stderr,"\n"); - fprintf(stderr,"Dump of constant symbol table\n"); - fprintf(stderr, - " address value flags\n"); - for (i = 0; i < CHSize; i++) - for (cptr = chash[i]; cptr != NULL; cptr = cptr->blink) { - fprintf(stderr," %8x %-40.40s ", cptr, cptr->image); - prt_flgs(cptr->flag); - } - fflush(stderr); - } - -/* - * fdump displays field symbol table to stderr. - */ -void fdump() - { - int i; - struct par_rec *prptr; - struct fentry *fp; - - fprintf(stderr,"\n"); - fprintf(stderr,"Dump of field symbol table\n"); - fprintf(stderr, - " address field global-ref offset\n"); - for (i = 0; i < FHSize; i++) - for (fp = fhash[i]; fp != NULL; fp = fp->blink) { - fprintf(stderr," %8x %20s\n", fp, fp->name); - for (prptr = fp->rlist; prptr != NULL; prptr = prptr->next) - fprintf(stderr," %8x %4d\n", - prptr->sym_entry, prptr->offset); - } - fflush(stderr); - } - -/* - * prt_flds - print a list of fields stored in reverse order. - */ -static void prt_flds(f) -struct fldname *f; - { - if (f == NULL) - return; - prt_flds(f->next); - fprintf(stderr, " %s", f->name); - } - -/* - * rdump displays list of records and their fields. - */ -void rdump() - { - struct rentry *rp; - - fprintf(stderr,"\n"); - fprintf(stderr,"Dump of record list\n"); - fprintf(stderr, " global-ref fields\n"); - for (rp = rec_lst; rp != NULL; rp = rp->next) { - fprintf(stderr, " %8x ", rp->sym_entry); - prt_flds(rp->fields); - fprintf(stderr, "\n"); - } - } -#endif /* DeBug */ - -/* - * alcloc allocates a local symbol table entry, fills in fields with - * specified values and returns pointer to new entry. - */ -static struct lentry *alcloc(blink, name, flag) -struct lentry *blink; -char *name; -int flag; - { - register struct lentry *lp; - - lp = NewStruct(lentry); - lp->blink = blink; - lp->name = name; - lp->flag = flag; - return lp; - } - -/* - * alcfld allocates a field symbol table entry, fills in the entry with - * specified values and returns pointer to new entry. - */ -static struct fentry *alcfld(blink, name, rp) -struct fentry *blink; -char *name; -struct par_rec *rp; - { - register struct fentry *fp; - - fp = NewStruct(fentry); - fp->blink = blink; - fp->name = name; - fp->rlist = rp; - return fp; - } - -/* - * alcglob allocates a global symbol table entry, fills in fields with - * specified values and returns pointer to new entry. - */ -static struct gentry *alcglob(blink, name, flag) -struct gentry *blink; -char *name; -int flag; - { - register struct gentry *gp; - - gp = NewStruct(gentry); - gp->blink = blink; - gp->name = name; - gp->flag = flag; - return gp; - } - -/* - * alclit allocates a constant symbol table entry, fills in fields with - * specified values and returns pointer to new entry. - */ -static struct centry *alclit(blink, image, len, flag) -struct centry *blink; -char *image; -int len, flag; - { - register struct centry *cp; - - cp = NewStruct(centry); - cp->blink = blink; - cp->image = image; - cp->length = len; - cp->flag = flag; - switch (flag) { - case F_IntLit: - cp->u.intgr = iconint(image); - break; - case F_CsetLit: - cp->u.cset = bitvect(image, len); - break; - } - return cp; - } - -/* - * alcprec allocates an entry for the parent record list for a field. - */ -static struct par_rec *alcprec(rec, offset, next) -struct rentry *rec; -int offset; -struct par_rec *next; - { - register struct par_rec *rp; - - rp = NewStruct(par_rec); - rp->rec= rec; - rp->offset = offset; - rp->next = next; - return rp; - } - -/* - * resolve - resolve the scope of undeclared identifiers. - */ -void resolve(proc) -struct pentry *proc; - { - struct lentry **lhash; - register struct lentry *lp; - struct gentry *gp; - int i; - char *id; - - lhash = proc->lhash; - - for (i = 0; i < LHSize; ++i) { - lp = lhash[i]; - while (lp != NULL) { - id = lp->name; - if (lp->flag == 0) { /* undeclared */ - if ((gp = try_gbl(id)) != NULL) { /* check global */ - lp->flag = F_Global; - lp->val.global = gp; - } - else { /* implicit local */ - if (uwarn) { - fprintf(stderr, "%s undeclared identifier, procedure %s\n", - id, proc->name); - ++twarns; - } - lp->flag = F_Dynamic; - lp->next = proc->dynams; - proc->dynams = lp; - ++proc->ndynam; - } - } - lp = lp->blink; - } - } - } - -/* - * try_glb - see if the identifier is or should be a global variable. - */ -static struct gentry *try_gbl(id) -char *id; - { - struct gentry *gp; - register struct implement *iptr; - int nargs; - int n; - - gp = glookup(id); - if (gp == NULL) { - /* - * See if it is a built-in function. - */ - iptr = db_ilkup(id, bhash); - if (iptr == NULL) - return NULL; - else { - if (iptr->in_line == NULL) - nfatal(NULL, "built-in function not installed", id); - nargs = iptr->nargs; - if (nargs > 0 && iptr->arg_flgs[nargs - 1] & VarPrm) - nargs = -nargs; - gp = putglob(id, F_Global | F_Builtin); - gp->val.builtin = iptr; - - n = n_arg_sym(iptr); - if (n > max_sym) - max_sym = n; - } - } - return gp; - } - -/* - * invoc_grp - called when "invocable all" is encountered. - */ -void invoc_grp(grp) -char *grp; - { - if (grp == spec_str("all")) - str_inv = 1; /* enable full string invocation */ - else - tfatal("invalid operand to invocable", grp); - } - -/* - * invocbl - indicate that the operator is needed for for string invocation. - */ -void invocbl(op, arity) -nodeptr op; -int arity; - { - struct strinv *si; - - si = NewStruct(strinv); - si->op = op; - si->arity = arity; - si->next = strinvlst; - strinvlst = si; - } - -/* - * chkstrinv - check to see what is needed for string invocation. - */ -void chkstrinv() - { - struct strinv *si; - struct gentry *gp; - struct implement *ip; - char *op_name; - int arity; - int i; - - /* - * A table of procedure blocks for operators is set up for use by - * string invocation. - */ - op_tbl_sz = 0; - fprintf(codefile, "\nstatic B_IProc(2) init_op_tbl[OpTblSz]"); - - if (str_inv) { - /* - * All operations must be available for string invocation. Make sure all - * built-in functions have either been hidden by global declarations - * or are in global variables, make sure no global variables are - * optimized away, and make sure all operations are in the table of - * operations. - */ - for (i = 0; i < IHSize; ++i) /* built-in function table */ - for (ip = bhash[i]; ip != NULL; ip = ip->blink) - try_gbl(ip->name); - for (i = 0; i < GHSize; i++) /* global symbol table */ - for (gp = ghash[i]; gp != NULL; gp = gp->blink) - gp->flag |= F_StrInv; - for (i = 0; i < IHSize; ++i) /* operator table */ - for (ip = ohash[i]; ip != NULL; ip = ip->blink) - opstrinv(ip); - } - else { - /* - * selected operations must be available for string invocation. - */ - for (si = strinvlst; si != NULL; si = si->next) { - op_name = Str0(si->op); - if (isalpha(*op_name) || (*op_name == '_')) { - /* - * This needs to be something in a global variable: function, - * procedure, or constructor. - */ - gp = try_gbl(op_name); - if (gp == NULL) - nfatal(si->op, "not available for string invocation", op_name); - else - gp->flag |= F_StrInv; - } - else { - /* - * must be an operator. - */ - arity = si->arity; - i = IHasher(op_name); - for (ip = ohash[i]; ip != NULL && ip->op != op_name; - ip = ip->blink) - ; - if (arity < 0) { - /* - * Operators of all arities with this symbol. - */ - while (ip != NULL && ip->op == op_name) { - opstrinv(ip); - ip = ip->blink; - } - } - else { - /* - * Operator of a specific arity. - */ - while (ip != NULL && ip->nargs != arity) - ip = ip->blink; - if (ip == NULL || ip->op != op_name) - nfatal(si->op, "not available for string invocation", - op_name); - else - opstrinv(ip); - } - } - } - } - - /* - * Add definitions to the header file indicating the size of the operator - * table and finish the declaration in the code file. - */ - if (op_tbl_sz == 0) { - fprintf(inclfile, "#define OpTblSz 1\n"); - fprintf(inclfile, "int op_tbl_sz = 0;\n"); - fprintf(codefile, ";\n"); - } - else { - fprintf(inclfile, "#define OpTblSz %d\n", op_tbl_sz); - fprintf(inclfile, "int op_tbl_sz = OpTblSz;\n"); - fprintf(codefile, "\n };\n"); - } - } - -/* - * opstrinv - set up string invocation for an operator. - */ -static void opstrinv(ip) -struct implement *ip; - { - char c1, c2; - char *name; - char *op; - register char *s; - int nargs; - int n; - - if (ip == NULL || ip->iconc_flgs & InStrTbl) - return; - - /* - * Keep track of the maximum number of argument symbols in any operation - * so type inference can allocate enough storage for the worst case of - * general invocation. - */ - n = n_arg_sym(ip); - if (n > max_sym) - max_sym = n; - - name = ip->name; - c1 = ip->prefix[0]; - c2 = ip->prefix[1]; - op = ip->op; - nargs = ip->nargs; - if (ip->arg_flgs[nargs - 1] & VarPrm) - nargs = -nargs; /* indicate varargs with negative number of params */ - - if (op_tbl_sz++ == 0) { - fprintf(inclfile, "\n"); - fprintf(codefile, " = {\n"); - } - else - fprintf(codefile, ",\n"); - implproto(ip); /* output prototype */ - - /* - * Output procedure block for this operator into table used by string - * invocation. - */ - fprintf(codefile, " {T_Proc, 11, O%c%c_%s, %d, -1, 0, 0, {{%d, \"", c1, c2, - name, nargs, strlen(op)); - for (s = op; *s != '\0'; ++s) { - if (*s == '\\') - fprintf(codefile, "\\"); - fprintf(codefile, "%c", *s); - } - fprintf(codefile, "\"}}}"); - ip->iconc_flgs |= InStrTbl; - } - -/* - * n_arg_sym - determine the number of argument symbols (dereferenced - * and undereferenced arguments are separate symbols) for an operation - * in the data base. - */ -int n_arg_sym(ip) -struct implement *ip; - { - int i; - int num; - - num = 0; - for (i = 0; i < ip->nargs; ++i) { - if (ip->arg_flgs[i] & RtParm) - ++num; - if (ip->arg_flgs[i] & DrfPrm) - ++num; - } - return num; - } diff --git a/src/iconc/csym.h b/src/iconc/csym.h deleted file mode 100644 index cf104af..0000000 --- a/src/iconc/csym.h +++ /dev/null @@ -1,380 +0,0 @@ -/* - * Structures for symbol table entries. - */ - -#define MaybeTrue 1 /* condition might be true at run time */ -#define MaybeFalse 2 /* condition might be false at run time */ - -#define MayConvert 1 /* type conversion may convert the value */ -#define MayDefault 2 /* defaulting type conversion may use default */ -#define MayKeep 4 /* conversion may succeed without any actual conversion */ - -#ifdef OptimizeType -#define NULL_T 0x1000000 -#define REAL_T 0x2000000 -#define INT_T 0x4000000 -#define CSET_T 0x8000000 -#define STR_T 0x10000000 - -#define TYPINFO_BLOCK 400000 - -/* - * Optimized type structure for bit vectors - * All previous occurencess of unsigned int * (at least - * when refering to bit vectors) have been replaced by - * struct typinfo. - */ -struct typinfo { - unsigned int packed; /* packed representation of types */ - unsigned int *bits; /* full length bit vector */ -}; -#endif /* OptimizeType */ - -/* - * Data base type codes are mapped to type inferencing information using - * an array. - */ -struct typ_info { - int frst_bit; /* first bit in bit vector allocated to this type */ - int num_bits; /* number of bits in bit vector allocated to this type */ - int new_indx; /* index into arrays of allocated types for operation */ -#ifdef OptimizeType - struct typinfo *typ; /* for variables: initial type */ -#else /* OptimizeType */ - unsigned int *typ; /* for variabled: initial type */ -#endif /* OptimizeType */ - }; - -/* - * A type is a bit vector representing a union of basic types. There - * are 3 sizes of types: first class types (Icon language types), - * intermediate value types (first class types plus variable references), - * run-time routine types (intermediate value types plus internal - * references to descriptors such as set elements). When the size of - * the type is known from context, a simple bit vector can be used. - * In other contexts, the size must be included. - */ -struct type { - int size; -#ifdef OptimizeType - struct typinfo *bits; -#else /* OptimizeType */ - unsigned int *bits; -#endif /* OptimizeType */ - struct type *next; - }; - - -#define DecodeSize(x) (x & 0xFFFFFF) -#define DecodePacked(x) (x >> 24) -/* - * NumInts - convert from the number of bits in a bit vector to the - * number of integers implementing it. - */ -#define NumInts(n_bits) (n_bits - 1) / IntBits + 1 - -/* - * ClrTyp - zero out the bit vector for a type. - */ -#ifdef OptimizeType -#define ClrTyp(size,typ) {\ - int typ_indx;\ - if ((typ)->bits == NULL)\ - clr_packed((typ),(size));\ - else\ - for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ - (typ)->bits[typ_indx] = 0;} -#else /* OptimizeType */ -#define ClrTyp(size,typ) {\ - int typ_indx;\ - for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ - (typ)[typ_indx] = 0;} -#endif /* OptimizeType */ - -/* - * CpyTyp - copy a type of the given size from one bit vector to another. - */ -#ifdef OptimizeType -#define CpyTyp(nsize,src,dest) {\ - int typ_indx, num;\ - if (((src)->bits == NULL) && ((dest)->bits == NULL)) {\ - ClrTyp((nsize),(dest));\ - cpy_packed_to_packed((src),(dest),(nsize));\ - }\ - else if (((src)->bits == NULL) && ((dest)->bits != NULL)) {\ - ClrTyp((nsize),(dest));\ - xfer_packed_to_bits((src),(dest),(nsize));\ - }\ - else if (((src)->bits != NULL) && ((dest)->bits == NULL)) {\ - (dest)->bits = alloc_mem_typ(DecodeSize((dest)->packed));\ - xfer_packed_types((dest));\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ - (dest)->bits[typ_indx] = (src)->bits[typ_indx];\ - }\ - else\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ - (dest)->bits[typ_indx] = (src)->bits[typ_indx];} -#else /* OptimizeType */ -#define CpyTyp(size,src,dest) {\ - int typ_indx;\ - for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ - (dest)[typ_indx] = (src)[typ_indx];} -#endif /* OptimizeType */ - -/* - * MrgTyp - merge a type of the given size from one bit vector into another. - */ -#ifdef OptimizeType -#define MrgTyp(nsize,src,dest) {\ - int typ_indx;\ - if (((src)->bits == NULL) && ((dest)->bits == NULL))\ - mrg_packed_to_packed((src),(dest),(nsize));\ - else if (((src)->bits == NULL) && ((dest)->bits != NULL))\ - xfer_packed_to_bits((src),(dest),(nsize));\ - else if (((src)->bits != NULL) && ((dest)->bits == NULL)) {\ - (dest)->bits = alloc_mem_typ(DecodeSize((dest)->packed));\ - xfer_packed_types((dest));\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ - (dest)->bits[typ_indx] |= (src)->bits[typ_indx];\ - }\ - else\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ - (dest)->bits[typ_indx] |= (src)->bits[typ_indx];} -#else /* OptimizeType */ -#define MrgTyp(size,src,dest) {\ - int typ_indx;\ - for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ - (dest)[typ_indx] |= (src)[typ_indx];} -#endif /* OptimizeType */ - -/* - * ChkMrgTyp - merge a type of the given size from one bit vector into another, - * updating the changed flag if the destination is changed by the merger. - */ -#ifdef OptimizeType -#define ChkMrgTyp(nsize,src,dest) {\ - int typ_indx, ret; unsigned int old;\ - if (((src)->bits == NULL) && ((dest)->bits == NULL)) {\ - ret = mrg_packed_to_packed((src),(dest),(nsize));\ - changed += ret;\ - }\ - else if (((src)->bits == NULL) && ((dest)->bits != NULL)) {\ - ret = xfer_packed_to_bits((src),(dest),(nsize));\ - changed += ret;\ - }\ - else if (((src)->bits != NULL) && ((dest)->bits == NULL)) {\ - (dest)->bits = alloc_mem_typ(DecodeSize((dest)->packed));\ - xfer_packed_types((dest));\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx) {\ - old = (dest)->bits[typ_indx];\ - (dest)->bits[typ_indx] |= (src)->bits[typ_indx];\ - if (old != (dest)->bits[typ_indx]) ++changed;}\ - }\ - else\ - for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx) {\ - old = (dest)->bits[typ_indx];\ - (dest)->bits[typ_indx] |= (src)->bits[typ_indx];\ - if (old != (dest)->bits[typ_indx]) ++changed;}} -#else /* OptimizeType */ -#define ChkMrgTyp(size,src,dest) {\ - int typ_indx; unsigned int old;\ - for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx) {\ - old = (dest)[typ_indx];\ - (dest)[typ_indx] |= (src)[typ_indx];\ - if (old != (dest)[typ_indx]) ++changed;}} -#endif /* OptimizeType */ - - -struct centry { /* constant table entry */ - struct centry *blink; /* link for bucket chain */ - char *image; /* pointer to string image of literal */ - int length; /* length of string */ - union { - unsigned short *cset; /* pointer to bit string for cset literal */ - long intgr; /* value of integer literal */ - } u; - uword flag; /* type of literal flag */ - char prefix[PrfxSz+1]; /* unique prefix used in data block name */ - }; - -struct fentry { /* field table entry */ - struct fentry *blink; /* link for bucket chain */ - char *name; /* name of field */ - struct par_rec *rlist; /* head of list of records */ - }; - -struct lentry { /* local table entry */ - struct lentry *blink; /* link for bucket chain */ - char *name; /* name of variable */ - uword flag; /* variable flags */ - union { - struct gentry *global; /* for globals: global symbol table entry */ - int index; /* type index; run-time descriptor index */ - } val; - struct lentry *next; /* used for linking a class of variables */ - }; - -struct gentry { /* global table entry */ - struct gentry *blink; /* link for bucket chain */ - char *name; /* name of variable */ - uword flag; /* variable flags */ - union { - struct implement *builtin; /* pointer to built-in function */ - struct pentry *proc; /* pointer to procedure entry */ - struct rentry *rec; /* pointer to record entry */ - } val; - int index; /* index into global array */ - int init_type; /* initial type if procedure */ - }; - -/* - * Structure for list of parent records for a field name. - */ -struct par_rec { - struct rentry *rec; /* parent record */ - int offset; /* field's offset within this record */ - int mark; /* used during code generation */ - struct par_rec *next; - }; - -/* - * Structure for a procedure. - */ -struct pentry { - char *name; /* name of procedure */ - char prefix[PrfxSz+1]; /* prefix to make name unique */ - struct lentry **lhash; /* hash area for procedure's local table */ - int nargs; /* number of args */ - struct lentry *args; /* list of arguments in reverse order */ - int ndynam; /* number of dynamic locals */ - struct lentry *dynams; /* list of dynamics in reverse order */ - int nstatic; /* number of statics */ - struct lentry *statics; /* list of statics in reverse order */ - struct node *tree; /* syntax tree for procedure */ - int has_coexpr; /* this procedure contains co-expressions */ - int tnd_loc; /* number of tended dynamic locals */ - int ret_flag; /* proc returns, suspends, and/or fails */ - int reachable; /* this procedure may be executed */ - int iteration; /* last iteration of type inference performed */ - int arg_lst; /* for varargs - the type number of the list */ -#ifdef OptimizeType - struct typinfo *ret_typ; /* type returned from procedure */ -#else /* OptimizeType */ - unsigned int *ret_typ; /* type returned from procedure */ -#endif /* OptimizeType */ - struct store *in_store; /* store at start of procedure */ - struct store *susp_store; /* store for resumption points of procedure */ - struct store *out_store; /* store on exiting procedure */ - struct lentry **vartypmap; /* mapping from var types to symtab entries */ -#ifdef OptimizeType - struct typinfo *coexprs; /* co-expressions in which proc may be called */ -#else /* OptimizeType */ - unsigned int *coexprs; /* co-expressions in which proc may be called */ -#endif /* OptimizeType */ - struct pentry *next; - }; - -/* - * Structure for a record. - */ -struct rentry { - char *name; /* name of record */ - char prefix[PrfxSz+1]; /* prefix to make name unique */ - int frst_fld; /* offset of variable type of 1st field */ - int nfields; /* number of fields */ - struct fldname *fields; /* list of field names in reverse order */ - int rec_num; /* id number for record */ - struct rentry *next; - }; - -struct fldname { /* record field */ - char *name; /* field name */ - struct fldname *next; - }; - -/* - * Structure used to analyze whether a type_case statement can be in-lined. - * Only one type check is supported: the type_case will be implemented - * as an "if" statement. - */ -struct case_anlz { - int n_cases; /* number of cases actually needed for this use */ - int typcd; /* for "if" optimization, the type code to check */ - struct il_code *il_then; /* for "if" optimization, the then clause */ - struct il_code *il_else; /* for "if" optimization, the else clause */ - }; - -/* - * spec_op contains the implementations for operations with do not have - * standard unary/binary syntax. - */ -#define ToOp 0 /* index into spec_op of i to j */ -#define ToByOp 1 /* index into spec_op of i to j by k */ -#define SectOp 2 /* index into spec_op of x[i:j] */ -#define SubscOp 3 /* index into spec_op of x[i] */ -#define ListOp 4 /* index into spec_op of [e1, e2, ... ] */ -#define NumSpecOp 5 -extern struct implement *spec_op[NumSpecOp]; - -/* - * Flag values. - */ - -#define F_Global 01 /* variable declared global externally */ -#define F_Proc 04 /* procedure */ -#define F_Record 010 /* record */ -#define F_Dynamic 020 /* variable declared local dynamic */ -#define F_Static 040 /* variable declared local static */ -#define F_Builtin 0100 /* identifier refers to built-in procedure */ -#define F_StrInv 0200 /* variable needed for string invocation */ -#define F_ImpError 0400 /* procedure has default error */ -#define F_Argument 01000 /* variable is a formal parameter */ -#define F_IntLit 02000 /* literal is an integer */ -#define F_RealLit 04000 /* literal is a real */ -#define F_StrLit 010000 /* literal is a string */ -#define F_CsetLit 020000 /* literal is a cset */ -#define F_Field 040000 /* identifier refers to a record field */ -#define F_SmplInv 0100000 /* identifier only used in simple invocation */ - -/* - * Symbol table region pointers. - */ - -extern struct implement *bhash[]; /* hash area for built-in func table */ -extern struct centry *chash[]; /* hash area for constant table */ -extern struct fentry *fhash[]; /* hash area for field table */ -extern struct gentry *ghash[]; /* hash area for global table */ -extern struct implement *khash[]; /* hash area for keyword table */ -extern struct implement *ohash[]; /* hash area for operator table */ - -extern struct pentry *proc_lst; /* procedure list */ -extern struct rentry *rec_lst; /* record list */ - -extern int max_sym; /* max number of parameter symbols in run-time routines */ -extern int max_prm; /* max number of parameters for any invocable routine */ - -extern struct symtyps *cur_symtyps; /* maps run-time routine symbols to types */ -extern struct pentry *cur_proc; /* procedure currently being translated */ - -/* - * Hash functions for symbol tables. Note, hash table sizes (xHSize) - * are all a power of 2. - */ - -#define CHasher(x) (((word)x)&(CHSize-1)) /* constant symbol table */ -#define FHasher(x) (((word)x)&(FHSize-1)) /* field symbol table */ -#define GHasher(x) (((word)x)&(GHSize-1)) /* global symbol table */ -#define LHasher(x) (((word)x)&(LHSize-1)) /* local symbol table */ - -/* - * flags for implementation entries. - */ -#define ProtoPrint 1 /* a prototype has already been printed */ -#define InStrTbl 2 /* operator is in string table */ - -/* - * Whether an operation can fail may depend on whether error conversion - * is allowed. The following macro checks this. - */ -#define MightFail(ret_flag) ((ret_flag & DoesFail) ||\ - (err_conv && (ret_flag & DoesEFail))) diff --git a/src/iconc/ctoken.h b/src/iconc/ctoken.h deleted file mode 100644 index 1e95e98..0000000 --- a/src/iconc/ctoken.h +++ /dev/null @@ -1,111 +0,0 @@ -# define IDENT 257 -# define INTLIT 258 -# define REALLIT 259 -# define STRINGLIT 260 -# define CSETLIT 261 -# define EOFX 262 -# define BREAK 263 -# define BY 264 -# define CASE 265 -# define CREATE 266 -# define DEFAULT 267 -# define DO 268 -# define ELSE 269 -# define END 270 -# define EVERY 271 -# define FAIL 272 -# define GLOBAL 273 -# define IF 274 -# define INITIAL 275 -# define INVOCABLE 276 -# define LINK 277 -# define LOCAL 278 -# define NEXT 279 -# define NOT 280 -# define OF 281 -# define PROCEDURE 282 -# define RECORD 283 -# define REPEAT 284 -# define RETURN 285 -# define STATIC 286 -# define SUSPEND 287 -# define THEN 288 -# define TO 289 -# define UNTIL 290 -# define WHILE 291 -# define BANG 292 -# define MOD 293 -# define AUGMOD 294 -# define AND 295 -# define AUGAND 296 -# define STAR 297 -# define AUGSTAR 298 -# define INTER 299 -# define AUGINTER 300 -# define PLUS 301 -# define AUGPLUS 302 -# define UNION 303 -# define AUGUNION 304 -# define MINUS 305 -# define AUGMINUS 306 -# define DIFF 307 -# define AUGDIFF 308 -# define DOT 309 -# define SLASH 310 -# define AUGSLASH 311 -# define ASSIGN 312 -# define SWAP 313 -# define NMLT 314 -# define AUGNMLT 315 -# define REVASSIGN 316 -# define REVSWAP 317 -# define SLT 318 -# define AUGSLT 319 -# define SLE 320 -# define AUGSLE 321 -# define NMLE 322 -# define AUGNMLE 323 -# define NMEQ 324 -# define AUGNMEQ 325 -# define SEQ 326 -# define AUGSEQ 327 -# define EQUIV 328 -# define AUGEQUIV 329 -# define NMGT 330 -# define AUGNMGT 331 -# define NMGE 332 -# define AUGNMGE 333 -# define SGT 334 -# define AUGSGT 335 -# define SGE 336 -# define AUGSGE 337 -# define QMARK 338 -# define AUGQMARK 339 -# define AT 340 -# define AUGAT 341 -# define BACKSLASH 342 -# define CARET 343 -# define AUGCARET 344 -# define BAR 345 -# define CONCAT 346 -# define AUGCONCAT 347 -# define LCONCAT 348 -# define AUGLCONCAT 349 -# define TILDE 350 -# define NMNE 351 -# define AUGNMNE 352 -# define SNE 353 -# define AUGSNE 354 -# define NEQUIV 355 -# define AUGNEQUIV 356 -# define LPAREN 357 -# define RPAREN 358 -# define PCOLON 359 -# define COMMA 360 -# define MCOLON 361 -# define COLON 362 -# define SEMICOL 363 -# define LBRACK 364 -# define RBRACK 365 -# define LBRACE 366 -# define RBRACE 367 diff --git a/src/iconc/ctrans.c b/src/iconc/ctrans.c deleted file mode 100644 index 7d33ac5..0000000 --- a/src/iconc/ctrans.c +++ /dev/null @@ -1,184 +0,0 @@ -/* - * ctrans.c - main control of the translation process. - */ -#include "../h/gsupport.h" -#include "cglobals.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ctoken.h" -#include "ccode.h" -#include "cproto.h" - -/* - * Prototypes. - */ -static void trans1 (char *filename); - -/* - * Variables. - */ -int tfatals = 0; /* total number of fatal errors */ -int twarns = 0; /* total number of warnings */ -int nocode; /* set by lexer; unused in compiler */ -int in_line; /* current input line number */ -int incol; /* current input column number */ -int peekc; /* one-character look ahead */ -struct srcfile *srclst = NULL; /* list of source files to translate */ - -static char *lpath; /* LPATH value */ - -/* - * translate a number of files, returning an error count - */ -int trans() - { - register struct pentry *proc; - struct srcfile *sf; - - lpath = getenv("LPATH"); /* remains null if unspecified */ - - for (sf = srclst; sf != NULL; sf = sf->next) - trans1(sf->name); /* translate each file in turn */ - - if (!pponly) { - /* - * Resolve undeclared references. - */ - for (proc = proc_lst; proc != NULL; proc = proc->next) - resolve(proc); - -#ifdef DeBug - symdump(); -#endif /* DeBug */ - - if (tfatals == 0) { - chkstrinv(); /* see what needs be available for string invocation */ - chkinv(); /* perform "naive" optimizations */ - } - - if (tfatals == 0) - typeinfer(); /* perform type inference */ - - if (just_type_trace) - return tfatals; /* stop without generating code */ - - if (tfatals == 0) { - var_dcls(); /* output declarations for globals and statics */ - const_blks(); /* output blocks for cset and real literals */ - for (proc = proc_lst; proc != NULL; proc = proc->next) - proccode(proc); /* output code for a procedure */ - recconstr(rec_lst); /* output code for record constructors */ -/* ANTHONY */ -/* - print_ghash(); -*/ - } - } - - /* - * Report information about errors and warnings and be correct about it. - */ - if (tfatals == 1) - fprintf(stderr, "1 error; "); - else if (tfatals > 1) - fprintf(stderr, "%d errors; ", tfatals); - else if (verbose > 0) - fprintf(stderr, "No errors; "); - - if (twarns == 1) - fprintf(stderr, "1 warning\n"); - else if (twarns > 1) - fprintf(stderr, "%d warnings\n", twarns); - else if (verbose > 0) - fprintf(stderr, "no warnings\n"); - else if (tfatals > 0) - fprintf(stderr, "\n"); - -#ifdef TranStats - tokdump(); -#endif /* TranStats */ - - return tfatals; - } - -/* - * translate one file. - */ -static void trans1(filename) -char *filename; - { - in_line = 1; /* start with line 1, column 0 */ - incol = 0; - peekc = 0; /* clear character lookahead */ - - if (!ppinit(filename,lpath?lpath:".",m4pre)) { - tfatal(filename, "cannot open source file"); - return; - } - if (!largeints) /* undefine predef symbol if no -l option */ - ppdef("_LARGE_INTEGERS", (char *)NULL); - ppdef("_MULTITASKING", (char *)NULL); /* never defined in compiler */ - ppdef("_EVENT_MONITOR", (char *)NULL); - ppdef("_MEMORY_MONITOR", (char *)NULL); - ppdef("_VISUALIZATION", (char *)NULL); - - if (strcmp(filename,"-") == 0) - filename = "stdin"; - if (verbose > 0) - fprintf(stderr, "%s:\n",filename); - - tok_loc.n_file = filename; - in_line = 1; - - if (pponly) - ppecho(); /* preprocess only */ - else - yyparse(); /* Parse the input */ - } - -/* - * writecheck - check the return code from a stdio output operation - */ -void writecheck(rc) - int rc; - - { - if (rc < 0) - quit("unable to write to icode file"); - } - -/* - * lnkdcl - find file locally or on LPATH and add to source list. - */ -void lnkdcl(name) -char *name; -{ - struct srcfile **pp; - struct srcfile *p; - char buf[MaxPath]; - - if (pathfind(buf, lpath, name, SourceSuffix)) - src_file(buf); - else - tfatal("cannot resolve reference to file name", name); - } - -/* - * src_file - add the file name to the list of source files to be translated, - * if it is not already on the list. - */ -void src_file(name) -char *name; - { - struct srcfile **pp; - struct srcfile *p; - - for (pp = &srclst; *pp != NULL; pp = &(*pp)->next) - if (strcmp((*pp)->name, name) == 0) - return; - p = NewStruct(srcfile); - p->name = salloc(name); - p->next = NULL; - *pp = p; -} diff --git a/src/iconc/ctrans.h b/src/iconc/ctrans.h deleted file mode 100644 index 3e03d06..0000000 --- a/src/iconc/ctrans.h +++ /dev/null @@ -1,47 +0,0 @@ -/* - * Miscellaneous compiler-specific definitions. - */ - -#define Iconc - -#ifndef CUsage - #define CUsage "[-C C-comp] [-E] [-T] [-c] [-f{adelns}] [-n{acest}]\n\ - [-o ofile] [-p C-opts] [-r runtime] [-s] [-t] [-u] [-v i]" -#endif /* CUsage */ - -#define Abs(n) ((n) >= 0 ? (n) : -(n)) -#define Max(x,y) ((x)>(y)?(x):(y)) - -#define tonum(c) (isdigit(c) ? (c - '0') : ((c & 037) + 9)) - -/* - * Hash tables must be a power of 2. - */ -#define CHSize 128 /* size of constant hash table */ -#define FHSize 32 /* size of field hash table */ -#define GHSize 128 /* size of global hash table */ -#define LHSize 128 /* size of local hash table */ - -#define PrfxSz 3 /* size of prefix */ - -/* - * srcfile is used construct the queue of source files to be translated. - */ -struct srcfile { - char *name; - struct srcfile *next; - }; - -extern struct srcfile *srclst; - -/* - * External definitions needed throughout translator. - */ -extern int twarns; - -#ifdef TranStats -#include "tstats.h" -#else /* TranStats */ -#define TokInc(x) -#define TokDec(x) -#endif /* TranStats */ diff --git a/src/iconc/ctree.c b/src/iconc/ctree.c deleted file mode 100644 index 170a631..0000000 --- a/src/iconc/ctree.c +++ /dev/null @@ -1,777 +0,0 @@ -/* - * ctree.c -- functions for constructing parse trees. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "ctree.h" -#include "csym.h" -#include "ctoken.h" -#include "ccode.h" -#include "cproto.h" - -/* - * prototypes for static functions. - */ -static nodeptr chk_empty (nodeptr n); -static void put_elms (nodeptr t, nodeptr args, int slot); -static nodeptr subsc_nd (nodeptr op, nodeptr arg1, nodeptr arg2); - -/* - * tree[1-6] construct parse tree nodes with specified values. - * loc_model is a node containing the same line and column information - * as is needed in this node, while parameters a through d are values to - * be assigned to n_field[0-3]. Note that this could be done with a - * single routine; a separate routine for each node size is used for - * speed and simplicity. - */ - -nodeptr tree1(type) -int type; - { - register nodeptr t; - - t = NewNode(0); - t->n_type = type; - t->n_file = NULL; - t->n_line = 0; - t->n_col = 0; - t->freetmp = NULL; - return t; - } - -nodeptr tree2(type, loc_model) -int type; -nodeptr loc_model; - { - register nodeptr t; - - t = NewNode(0); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - return t; - } - -nodeptr tree3(type, loc_model, a) -int type; -nodeptr loc_model; -nodeptr a; - { - register nodeptr t; - - t = NewNode(1); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_ptr = a; - return t; - } - -nodeptr tree4(type, loc_model, a, b) -int type; -nodeptr loc_model; -nodeptr a, b; - { - register nodeptr t; - - t = NewNode(2); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_ptr = a; - t->n_field[1].n_ptr = b; - return t; - } - -nodeptr tree5(type, loc_model, a, b, c) -int type; -nodeptr loc_model; -nodeptr a, b, c; - { - register nodeptr t; - - t = NewNode(3); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_ptr = a; - t->n_field[1].n_ptr = b; - t->n_field[2].n_ptr = c; - return t; - } - -nodeptr tree6(type, loc_model, a, b, c, d) -int type; -nodeptr loc_model; -nodeptr a, b, c, d; - { - register nodeptr t; - - t = NewNode(4); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_ptr = a; - t->n_field[1].n_ptr = b; - t->n_field[2].n_ptr = c; - t->n_field[3].n_ptr = d; - return t; - } - -nodeptr int_leaf(type, loc_model, a) -int type; -nodeptr loc_model; -int a; - { - register nodeptr t; - - t = NewNode(1); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = a; - return t; - } - -nodeptr c_str_leaf(type, loc_model, a) -int type; -nodeptr loc_model; -char *a; - { - register nodeptr t; - - t = NewNode(1); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_str = a; - return t; - } - -/* - * i_str_leaf - create a leaf node containing a string and length. - */ -nodeptr i_str_leaf(type, loc_model, a, b) -int type; -nodeptr loc_model; -char *a; -int b; - { - register nodeptr t; - - t = NewNode(2); - t->n_type = type; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_str = a; - t->n_field[1].n_val = b; - return t; - } - -/* - * key_leaf - create a leaf node for a keyword. - */ -nodeptr key_leaf(loc_model, keyname) -nodeptr loc_model; -char *keyname; - { - register nodeptr t; - struct implement *ip; - struct il_code *il; - char *s; - int typcd; - - /* - * Find the data base entry for the keyword, if it exists. - */ - ip = db_ilkup(keyname, khash); - - if (ip == NULL) - tfatal("invalid keyword", keyname); - else if (ip->in_line == NULL) - tfatal("keyword not installed", keyname); - else { - il = ip->in_line; - s = il->u[1].s; - if (il->il_type == IL_Const) { - /* - * This is a constant keyword, treat it as a literal. - */ - t = NewNode(1); - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - typcd = il->u[0].n; - if (typcd == cset_typ) { - t->n_type = N_Cset; - CSym0(t) = putlit(&s[1], F_CsetLit, strlen(s) - 2); - } - else if (typcd == int_typ) { - t->n_type = N_Int; - CSym0(t) = putlit(s, F_IntLit, 0); - } - else if (typcd == real_typ) { - t->n_type = N_Real; - CSym0(t) = putlit(s, F_RealLit, 0); - } - else if (typcd == str_typ) { - t->n_type = N_Str; - CSym0(t) = putlit(&s[1], F_StrLit, strlen(s) - 2); - } - return t; - } - } - - t = NewNode(2); - t->n_type = N_InvOp; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 0; /* number of arguments */ - t->n_field[1].ip = ip; - return t; - } - -/* - * list_nd - create a list creation node. - */ -nodeptr list_nd(loc_model, args) -nodeptr loc_model; -nodeptr args; - { - register nodeptr t; - struct implement *impl; - int nargs; - - /* - * Determine the number of arguments. - */ - if (args->n_type == N_Empty) - nargs = 0; - else { - nargs = 1; - for (t = args; t->n_type == N_Elist; t = t->n_field[0].n_ptr) - ++nargs; - if (nargs > max_prm) - max_prm = nargs; - } - - impl = spec_op[ListOp]; - if (impl == NULL) - nfatal(loc_model, "list creation not implemented", NULL); - else if (impl->in_line == NULL) - nfatal(loc_model, "list creation not installed", NULL); - - t = NewNode(nargs + 2); - t->n_type = N_InvOp; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = nargs; - t->n_field[1].ip = impl; - if (nargs > 0) - put_elms(t, args, nargs + 1); - return t; - } - -/* - * invk_nd - create a node for invocation. - */ -nodeptr invk_nd(loc_model, proc, args) -nodeptr loc_model; -nodeptr proc; -nodeptr args; - { - register nodeptr t; - int nargs; - - /* - * Determine the number of arguments. - */ - if (args->n_type == N_Empty) - nargs = 0; - else { - nargs = 1; - for (t = args; t->n_type == N_Elist; t = t->n_field[0].n_ptr) - ++nargs; - if (nargs > max_prm) - max_prm = nargs; - } - - t = NewNode(nargs + 2); - t->n_type = N_Invok; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = nargs; - t->n_field[1].n_ptr = proc; - if (nargs > 0) - put_elms(t, args, nargs + 1); - return t; - } - -/* - * put_elms - convert a linked list of arguments into an array of arguments - * in a node. - */ -static void put_elms(t, args, slot) -nodeptr t; -nodeptr args; -int slot; - { - if (args->n_type == N_Elist) { - /* - * The linked list is in reverse argument order. - */ - t->n_field[slot].n_ptr = chk_empty(args->n_field[1].n_ptr); - put_elms(t, args->n_field[0].n_ptr, slot - 1); - free(args); - } - else - t->n_field[slot].n_ptr = chk_empty(args); - } - -/* - * chk_empty - if an argument is empty, replace it with &null. - */ -static nodeptr chk_empty(n) -nodeptr n; - { - if (n->n_type == N_Empty) - n = key_leaf(n, spec_str("null")); - return n; - } - -/* - * case_nd - create a node for a case statement. - */ -nodeptr case_nd(loc_model, expr, cases) -nodeptr loc_model; -nodeptr expr; -nodeptr cases; - { - register nodeptr t; - nodeptr reverse; - nodeptr nxt_cases; - nodeptr ccls; - - t = NewNode(3); - t->n_type = N_Case; - t->n_file = loc_model->n_file; - t->n_line = loc_model->n_line; - t->n_col = loc_model->n_col; - t->freetmp = NULL; - t->n_field[0].n_ptr = expr; - t->n_field[2].n_ptr = NULL; - - /* - * The list of cases is in reverse order. Walk the list reversing it, - * and extract the default clause if one exists. - */ - reverse = NULL; - while (cases->n_type != N_Ccls) { - nxt_cases = cases->n_field[0].n_ptr; - ccls = cases->n_field[1].n_ptr; - if (ccls->n_field[0].n_ptr->n_type == N_Res) { - /* - * default clause. - */ - if (t->n_field[2].n_ptr == NULL) - t->n_field[2].n_ptr = ccls->n_field[1].n_ptr; - else - nfatal(ccls, "duplicate default clause", NULL); - } - else { - if (reverse == NULL) { - reverse = cases; - reverse->n_field[0].n_ptr = ccls; - } - else { - reverse->n_field[1].n_ptr = ccls; - cases->n_field[0].n_ptr = reverse; - reverse = cases; - } - } - cases = nxt_cases; - } - - /* - * Last element in list. - */ - if (cases->n_field[0].n_ptr->n_type == N_Res) { - /* - * default clause. - */ - if (t->n_field[2].n_ptr == NULL) - t->n_field[2].n_ptr = cases->n_field[1].n_ptr; - else - nfatal(ccls, "duplicate default clause", NULL); - if (reverse != NULL) - reverse = reverse->n_field[0].n_ptr; - } - else { - if (reverse == NULL) - reverse = cases; - else - reverse->n_field[1].n_ptr = cases; - } - t->n_field[1].n_ptr = reverse; - return t; - } - -/* - * multiunary - construct nodes to implement a sequence of unary operators - * that have been lexically analyzed as one operator. - */ -nodeptr multiunary(op, loc_model, oprnd) -nodeptr loc_model; -char *op; -nodeptr oprnd; - { - int n; - nodeptr nd; - - if (*op == '\0') - return oprnd; - for (n = 0; optab[n].tok.t_word != NULL; ++n) - if ((optab[n].expected & Unary) & (*(optab[n].tok.t_word) == *op)) { - nd = OpNode(n); - nd->n_file = loc_model->n_file; - nd->n_line = loc_model->n_line; - nd->n_col = loc_model->n_col; - return unary_nd(nd,multiunary(++op,loc_model,oprnd)); - } - fprintf(stderr, "compiler error: inconsistent parsing of unary operators"); - exit(EXIT_FAILURE); - } - -/* - * binary_nd - construct a node for a binary operator. - */ -nodeptr binary_nd(op, arg1, arg2) -nodeptr op; -nodeptr arg1; -nodeptr arg2; - { - register nodeptr t; - struct implement *impl; - - /* - * Find the data base entry for the operator. - */ - impl = optab[Val0(op)].binary; - if (impl == NULL) - nfatal(op, "binary operator not implemented", optab[Val0(op)].tok.t_word); - else if (impl->in_line == NULL) - nfatal(op, "binary operator not installed", optab[Val0(op)].tok.t_word); - - t = NewNode(4); - t->n_type = N_InvOp; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 2; /* number of arguments */ - t->n_field[1].ip = impl; - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - return t; - } - -/* - * unary_nd - construct a node for a unary operator. - */ -nodeptr unary_nd(op, arg) -nodeptr op; -nodeptr arg; - { - register nodeptr t; - struct implement *impl; - - /* - * Find the data base entry for the operator. - */ - impl = optab[Val0(op)].unary; - if (impl == NULL) - nfatal(op, "unary operator not implemented", optab[Val0(op)].tok.t_word); - else if (impl->in_line == NULL) - nfatal(op, "unary operator not installed", optab[Val0(op)].tok.t_word); - - t = NewNode(3); - t->n_type = N_InvOp; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 1; /* number of arguments */ - t->n_field[1].ip = impl; - t->n_field[2].n_ptr = arg; - return t; - } - -/* - * buildarray - convert "multi-dimensional" subscripting into a sequence - * of subsripting operations. - */ -nodeptr buildarray(a,lb,e) -nodeptr a, lb, e; - { - register nodeptr t, t2; - if (e->n_type == N_Elist) { - t2 = int_leaf(lb->n_type, lb, lb->n_field[0].n_val); - t = subsc_nd(t2, buildarray(a,lb,e->n_field[0].n_ptr), - e->n_field[1].n_ptr); - free(e); - } - else - t = subsc_nd(lb, a, e); - return t; - } - -/* - * subsc_nd - construct a node for subscripting. - */ -static nodeptr subsc_nd(op, arg1, arg2) -nodeptr op; -nodeptr arg1; -nodeptr arg2; - { - register nodeptr t; - struct implement *impl; - - /* - * Find the data base entry for subscripting. - */ - impl = spec_op[SubscOp]; - if (impl == NULL) - nfatal(op, "subscripting not implemented", NULL); - else if (impl->in_line == NULL) - nfatal(op, "subscripting not installed", NULL); - - t = NewNode(4); - t->n_type = N_InvOp; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 2; /* number of arguments */ - t->n_field[1].ip = impl; - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - return t; - } - -/* - * to_nd - construct a node for binary to. - */ -nodeptr to_nd(op, arg1, arg2) -nodeptr op; -nodeptr arg1; -nodeptr arg2; - { - register nodeptr t; - struct implement *impl; - - /* - * Find the data base entry for to. - */ - impl = spec_op[ToOp]; - if (impl == NULL) - nfatal(op, "'i to j' not implemented", NULL); - else if (impl->in_line == NULL) - nfatal(op, "'i to j' not installed", NULL); - - t = NewNode(4); - t->n_type = N_InvOp; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 2; /* number of arguments */ - t->n_field[1].ip = impl; - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - return t; - } - -/* - * toby_nd - construct a node for binary to-by. - */ -nodeptr toby_nd(op, arg1, arg2, arg3) -nodeptr op; -nodeptr arg1; -nodeptr arg2; -nodeptr arg3; - { - register nodeptr t; - struct implement *impl; - - /* - * Find the data base entry for to-by. - */ - impl = spec_op[ToByOp]; - if (impl == NULL) - nfatal(op, "'i to j by k' not implemented", NULL); - else if (impl->in_line == NULL) - nfatal(op, "'i to j by k' not installed", NULL); - - t = NewNode(5); - t->n_type = N_InvOp; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - t->n_field[0].n_val = 3; /* number of arguments */ - t->n_field[1].ip = impl; - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - t->n_field[4].n_ptr = arg3; - return t; - } - -/* - * aug_nd - create a node for an augmented assignment. - */ -nodeptr aug_nd(op, arg1, arg2) -nodeptr op; -nodeptr arg1; -nodeptr arg2; - { - register nodeptr t; - struct implement *impl; - - t = NewNode(5); - t->n_type = N_Augop; - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - - /* - * Find the data base entry for assignment. - */ - impl = optab[asgn_loc].binary; - if (impl == NULL) - nfatal(op, "assignment not implemented", NULL); - t->n_field[0].ip = impl; - - /* - * The operator table entry for the augmented assignment is - * immediately after the entry for the operation. - */ - impl = optab[Val0(op) - 1].binary; - if (impl == NULL) - nfatal(op, "binary operator not implemented", - optab[Val0(op) - 1].tok.t_word); - t->n_field[1].ip = impl; - - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - /* t->n_field[4].typ - type of intermediate result */ - return t; - } - -/* - * sect_nd - create a node for sectioning. - */ -nodeptr sect_nd(op, arg1, arg2, arg3) -nodeptr op; -nodeptr arg1; -nodeptr arg2; -nodeptr arg3; - { - register nodeptr t; - int tok; - struct implement *impl; - struct implement *impl1; - - t = NewNode(5); - t->n_file = op->n_file; - t->n_line = op->n_line; - t->n_col = op->n_col; - t->freetmp = NULL; - - /* - * Find the data base entry for sectioning. - */ - impl = spec_op[SectOp]; - if (impl == NULL) - nfatal(op, "sectioning not implemented", NULL); - - tok = optab[Val0(op)].tok.t_type; - if (tok == COLON) { - /* - * Simple sectioning, treat as a ternary operator. - */ - t->n_type = N_InvOp; - t->n_field[0].n_val = 3; /* number of arguments */ - t->n_field[1].ip = impl; - } - else { - /* - * Find the data base entry for addition or subtraction. - */ - if (tok == PCOLON) { - impl1 = optab[plus_loc].binary; - if (impl1 == NULL) - nfatal(op, "addition not implemented", NULL); - } - else { /* MCOLON */ - impl1 = optab[minus_loc].binary; - if (impl1 == NULL) - nfatal(op, "subtraction not implemented", NULL); - } - t->n_type = N_Sect; - t->n_field[0].ip = impl; - t->n_field[1].ip = impl1; - } - t->n_field[2].n_ptr = arg1; - t->n_field[3].n_ptr = arg2; - t->n_field[4].n_ptr = arg3; - return t; - } - -/* - * invk_main - produce an procedure invocation node with one argument for - * use in the initial invocation to main() during type inference. - */ -nodeptr invk_main(main_proc) -struct pentry *main_proc; - { - register nodeptr t; - - t = NewNode(3); - t->n_type = N_InvProc; - t->n_file = NULL; - t->n_line = 0; - t->n_col = 0; - t->freetmp = NULL; - t->n_field[0].n_val = 1; /* 1 argument */ - t->n_field[1].proc = main_proc; - t->n_field[2].n_ptr = tree1(N_Empty); - - if (max_prm < 1) - max_prm = 1; - return t; - } diff --git a/src/iconc/ctree.h b/src/iconc/ctree.h deleted file mode 100644 index d38d3c4..0000000 --- a/src/iconc/ctree.h +++ /dev/null @@ -1,200 +0,0 @@ -/* - * Structure of a tree node. - */ - -typedef struct node *nodeptr; - -/* - * Kinds of fields in syntax tree node. - */ -union field { - long n_val; /* integer-valued fields */ - char *n_str; /* string-valued fields */ - struct lentry *lsym; /* fields referencing local symbol table entries */ - struct centry *csym; /* fields referencing constant symbol table entries */ - struct implement *ip; /* fields referencing an operation */ - struct pentry *proc; /* pointer to procedure entry */ - struct rentry *rec; /* pointer to record entry */ -#ifdef OptimizeType - struct typinfo *typ; /* extra type field */ -#else /* OptimizeType */ - unsigned int *typ; /* extra type field */ -#endif /* OptimizeType */ - nodeptr n_ptr; /* subtree pointers */ - }; - -/* - * A store is an array that maps variables types (which are given indexes) - * to the types stored within the variables. - */ -struct store { - struct store *next; - int perm; /* flag: whether store stays across iterations */ -#ifdef OptimizeType - struct typinfo *types[1]; /* actual size is number of variables */ -#else /* OptimizeType */ - unsigned int *types[1]; /* actual size is number of variables */ -#endif /* OptimizeType */ - }; - -/* - * Array of parameter types for an operation call. - */ -struct symtyps { - int nsyms; /* number of parameter symbols */ - struct symtyps *next; -#ifdef OptimizeType - struct typinfo *types[1]; /* really one for every symbol */ -#else /* OptimizeType */ - unsigned int *types[1]; /* really one for every symbol */ -#endif /* OptimizeType */ - }; - -/* - * definitions for maintaining allocation status. - */ -#define NotAlloc 0 /* temp var neither in use nor reserved */ -#define InUnse 1 /* temp var currently contains live variable */ -/* n < 0 reserved: must be free by node with postn field = n */ - -#define DescTmp 1 /* allocation of descriptor temporary */ -#define CIntTmp 2 /* allocation of C integer temporary */ -#define CDblTmp 3 /* allocation of C double temporary */ -#define SBuf 4 /* allocation of string buffer */ -#define CBuf 5 /* allocation of cset buffer */ - -struct freetmp { /* list of things to free at a node */ - int kind; /* DescTmp, CIntTmp, CDblTmp, SBuf, or CBuf */ - int indx; /* index into status array */ - int old; /* old status */ - struct freetmp *next; - }; - -struct node { - int n_type; /* node type */ - char *n_file; /* name of file containing source program */ - int n_line; /* line number in source program */ - int n_col; /* column number in source program */ - int flag; - int *new_types; /* pntr to array of struct types created here */ -#ifdef OptimizeType - struct typinfo *type; /* type of this expression */ -#else /* OptimizeType */ - unsigned int *type; /* type of this expression */ -#endif /* OptimizeType */ - struct store *store; /* if needed, store saved between iterations */ - struct symtyps *symtyps; /* for operation in data base: types of arg syms */ - nodeptr lifetime; /* lifetime of intermediate result */ - int reuse; /* result may be reused without being recomputed */ - nodeptr intrnl_lftm; /* lifetime of variables internal to operation */ - int postn; /* relative position of node in execution order */ - struct freetmp *freetmp; /* temporary variables to free at this point */ - union field n_field[1]; /* node fields */ - }; - -/* - * NewNode - allocate a parse tree node with "size" fields. - */ -#define NewNode(size) (struct node *)alloc((unsigned int)\ - (sizeof(struct node) + (size-1) * sizeof(union field))) - -/* - * Macros to access fields of parse tree nodes. - */ - -#define Type(t) t->n_type -#define File(t) t->n_file -#define Line(t) t->n_line -#define Col(t) t->n_col -#define Tree0(t) t->n_field[0].n_ptr -#define Tree1(t) t->n_field[1].n_ptr -#define Tree2(t) t->n_field[2].n_ptr -#define Tree3(t) t->n_field[3].n_ptr -#define Tree4(t) t->n_field[4].n_ptr -#define Val0(t) t->n_field[0].n_val -#define Val1(t) t->n_field[1].n_val -#define Val2(t) t->n_field[2].n_val -#define Val3(t) t->n_field[3].n_val -#define Val4(t) t->n_field[4].n_val -#define Str0(t) t->n_field[0].n_str -#define Str1(t) t->n_field[1].n_str -#define Str2(t) t->n_field[2].n_str -#define Str3(t) t->n_field[3].n_str -#define LSym0(t) t->n_field[0].lsym -#define CSym0(t) t->n_field[0].csym -#define Impl0(t) t->n_field[0].ip -#define Impl1(t) t->n_field[1].ip -#define Rec1(t) t->n_field[1].rec -#define Proc1(t) t->n_field[1].proc -#define Typ4(t) t->n_field[4].typ - -/* - * External declarations. - */ - -extern nodeptr yylval; /* parser's current token value */ -extern struct node tok_loc; /* "model" token holding current location */ - -/* - * Node types. - */ - -#define N_Activat 1 /* activation control structure */ -#define N_Alt 2 /* alternation operator */ -#define N_Apply 3 /* procedure application */ -#define N_Augop 4 /* augmented operator */ -#define N_Bar 5 /* generator control structure */ -#define N_Break 6 /* break statement */ -#define N_Case 7 /* case statement */ -#define N_Ccls 8 /* case clause */ -#define N_Clist 9 /* list of case clauses */ -#define N_Create 10 /* create control structure */ -#define N_Cset 11 /* cset literal */ -#define N_Elist 12 /* list of expressions */ -#define N_Empty 13 /* empty expression or statement */ -#define N_Field 14 /* record field reference */ -#define N_Id 15 /* identifier token */ -#define N_If 16 /* if-then-else statement */ -#define N_Int 17 /* integer literal */ -#define N_Invok 18 /* invocation */ -#define N_InvOp 19 /* invoke operation */ -#define N_InvProc 20 /* invoke operation */ -#define N_InvRec 21 /* invoke operation */ -#define N_Limit 22 /* LIMIT control structure */ -#define N_Loop 23 /* while, until, every, or repeat */ -#define N_Next 24 /* next statement */ -#define N_Not 25 /* not prefix control structure */ -#define N_Op 26 /* operator token */ -#define N_Proc 27 /* procedure */ -#define N_Real 28 /* real literal */ -#define N_Res 29 /* reserved word token */ -#define N_Ret 30 /* fail, return, or succeed */ -#define N_Scan 31 /* scan-using statement */ -#define N_Sect 32 /* s[i:j] (section) */ -#define N_Slist 33 /* list of statements */ -#define N_Str 34 /* string literal */ -#define N_SmplAsgn 35 /* simple assignment to named var */ -#define N_SmplAug 36 /* simple assignment to named var */ - -#define AsgnDirect 0 /* rhs of special := can compute directly into var */ -#define AsgnCopy 1 /* special := must copy result into var */ -#define AsgnDeref 2 /* special := must dereference result into var */ - - -/* - * Macros for constructing basic nodes. - */ - -#define CsetNode(a,b) i_str_leaf(N_Cset,&tok_loc,a,b) -#define IdNode(a) c_str_leaf(N_Id,&tok_loc,a) -#define IntNode(a) c_str_leaf(N_Int,&tok_loc,a) -#define OpNode(a) int_leaf(N_Op,&tok_loc,a) -#define RealNode(a) c_str_leaf(N_Real,&tok_loc,a) -#define ResNode(a) int_leaf(N_Res,&tok_loc,a) -#define StrNode(a,b) i_str_leaf(N_Str,&tok_loc,a,b) - -/* - * MultiUnary - create subtree from an operator symbol that represents - * multiple unary operators. - */ -#define MultiUnary(a,b) multiunary(optab[Val0(a)].tok.t_word, a, b) diff --git a/src/iconc/dbase.c b/src/iconc/dbase.c deleted file mode 100644 index fdd3e50..0000000 --- a/src/iconc/dbase.c +++ /dev/null @@ -1,196 +0,0 @@ -/* - * dbase.c - routines to access data base of implementation information - * produced by rtt. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ccode.h" -#include "cproto.h" -#include "cglobals.h" - -/* - * Prototypes. - */ -static int chck_spec (struct implement *ip); -static int acpt_op (struct implement *ip); - - -static struct optab *optr; /* pointer into operator table */ - -/* - * readdb - read data base produced by rtt. - */ -void readdb(db_name) -char *db_name; - { - char *op, *s; - int i; - struct implement *ip; - char buf[MaxPath]; /* file name construction buffer */ - struct fileparts *fp; - unsigned hashval; - - fp = fparse(db_name); - if (*fp->ext == '\0') - db_name = salloc(makename(buf, NULL, db_name, DBSuffix)); - else if (!smatch(fp->ext, DBSuffix)) - quitf("bad data base name: %s", db_name); - - if (!db_open(db_name, &s)) - db_err1(1, "cannot open data base"); - - if (largeints && (*s == 'N')) { - twarn("Warning, run-time system does not support large integers", NULL); - largeints = 0; - } - - /* - * Read information about functions. - */ - db_tbl("functions", bhash); - - /* - * Read information about operators. - */ - optr = optab; - - /* - * read past operators header. - */ - db_chstr("operators", "operators"); - - while ((op = db_string()) != NULL) { - if ((ip = db_impl('O')) == NULL) - db_err2(1, "no implementation information for operator", op); - ip->op = op; - if (acpt_op(ip)) { - db_code(ip); - hashval = IHasher(op); - ip->blink = ohash[hashval]; - ohash[hashval] = ip; - db_chstr("end", "end"); - } - else - db_dscrd(ip); - } - db_chstr("endsect", "endsect"); - - /* - * Read information about keywords. - */ - db_tbl("keywords", khash); - - db_close(); - - /* - * If error conversion is supported, make sure it is reflected in - * the minimum result sequence of operations. - */ - if (err_conv) { - for (i = 0; i < IHSize; ++i) - for (ip = bhash[i]; ip != NULL; ip = ip->blink) - if (ip->ret_flag & DoesEFail) - ip->min_result = 0; - for (i = 0; i < IHSize; ++i) - for (ip = ohash[i]; ip != NULL; ip = ip->blink) - if (ip->ret_flag & DoesEFail) - ip->min_result = 0; - for (i = 0; i < IHSize; ++i) - for (ip = khash[i]; ip != NULL; ip = ip->blink) - if (ip->ret_flag & DoesEFail) - ip->min_result = 0; - } - } - -/* - * acpt_opt - given a data base entry for an operator determine if it - * is in iconc's operator table. - */ -static int acpt_op(ip) -struct implement *ip; - { - register char *op; - register int opcmp; - - /* - * Calls to this function are in lexical order by operator symbol continue - * searching operator table from where we left off. - */ - op = ip->op; - for (;;) { - /* - * optab has augmented assignments out of lexical order. Skip anything - * which does not expect an implementation. This gets augmented - * assignments out of the way. - */ - while (optr->expected == 0 && optr->tok.t_word != NULL) - ++optr; - if (optr->tok.t_word == NULL) - return chck_spec(ip); - opcmp = strcmp(op, optr->tok.t_word); - if (opcmp > 0) - ++optr; - else if (opcmp < 0) - return chck_spec(ip); - else { - if (ip->nargs == 1 && (optr->expected & Unary)) { - if (optr->unary == NULL) { - optr->unary = ip; - return 1; - } - else - return 0; - } - else if (ip->nargs == 2 && (optr->expected & Binary)) { - if (optr->binary == NULL) { - optr->binary = ip; - return 1; - } - else - return 0; - } - else - return chck_spec(ip); - } - } - } - -/* - * chck_spec - check whether the operator is one that does not use standard - * unary or binary syntax. - */ -static int chck_spec(ip) -struct implement *ip; - { - register char *op; - int indx; - - indx = -1; - op = ip->op; - if (strcmp(op, "...") == 0) { - if (ip->nargs == 2) - indx = ToOp; - else - indx = ToByOp; - } - else if (strcmp(op, "[:]") == 0) - indx = SectOp; - else if (strcmp(op, "[]") == 0) - indx = SubscOp; - else if (strcmp(op, "[...]") == 0) - indx = ListOp; - - if (indx == -1) { - db_err2(0, "unexpected operator (or arity),", op); - return 0; - } - if (spec_op[indx] == NULL) { - spec_op[indx] = ip; - return 1; - } - else - return 0; - } diff --git a/src/iconc/fixcode.c b/src/iconc/fixcode.c deleted file mode 100644 index b8c06e0..0000000 --- a/src/iconc/fixcode.c +++ /dev/null @@ -1,372 +0,0 @@ -/* - * fixcode.c - routines to "fix code" by determining what signals are returned - * by continuations and what must be done when they are. Also perform - * optional control flow optimizations. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "cglobals.h" -#include "ccode.h" -#include "ctree.h" -#include "csym.h" -#include "cproto.h" - -/* - * Prototypes for static functions. - */ -static struct code *ck_unneed (struct code *cd, struct code *lbl); -static void clps_brch (struct code *branch); -static void dec_refs (struct code *cd); -static void rm_unrch (struct code *cd); - -/* - * fix_fncs - go through the generated C functions, determine how calls - * handle signals, in-line trivial functions where possible, remove - * goto's which immediately precede their labels, and remove unreachable - * code. - */ -void fix_fncs(fnc) -struct c_fnc *fnc; - { - struct code *cd, *cd1; - struct code *contbody; - struct sig_act *sa; - struct sig_lst *sl; - struct code *call; - struct code *create; - struct code *ret_sig; - struct code *sig; - struct c_fnc *calledcont; - int no_break; - int collapse; - - /* - * Fix any called functions and decide how the calls handle the - * returned signals. - */ - fnc->flag |= CF_Mark; - for (call = fnc->call_lst; call != NULL; call = call->NextCall) { - calledcont = call->Cont; - if (calledcont != NULL) { - if (!(calledcont->flag & CF_Mark)) - fix_fncs(calledcont); - if (calledcont->flag & CF_ForeignSig) { - call->Flags |= ForeignSig; - fnc->flag |= CF_ForeignSig; - } - } - - - /* - * Try to collapse call chains of continuations. - */ - if (opt_cntrl && calledcont != NULL) { - contbody = calledcont->cd.next; - if (call->OperName == NULL && contbody->cd_id == C_RetSig) { - /* - * A direct call of a continuation which consists of just a - * return. Replace call with code to handle the returned signal. - */ - ret_sig = contbody->SigRef->sig; - if (ret_sig == &resume) - cd1 = sig_cd(call->ContFail, fnc); - else - cd1 = sig_cd(ret_sig, fnc); - cd1->prev = call->prev; - cd1->prev->next = cd1; - cd1->next = call->next; - if (cd1->next != NULL) - cd1->next->prev = cd1; - --calledcont->ref_cnt; - continue; /* move on to next call */ - } - else if (contbody->cd_id == C_CallSig && contbody->next == NULL) { - /* - * The called continuation contains only a call. - */ - if (call->OperName == NULL) { - /* - * We call the continuation directly, so we can in-line it. - * We must replace signal returns with appropriate actions. - */ - if (--calledcont->ref_cnt != 0 && contbody->Cont != NULL) - ++contbody->Cont->ref_cnt; - call->OperName = contbody->OperName; - call->ArgLst = contbody->ArgLst; - call->Cont = contbody->Cont; - call->Flags = contbody->Flags; - for (sa = contbody->SigActs; sa != NULL; sa = sa->next) { - ret_sig = sa->cd->SigRef->sig; - if (ret_sig == &resume) - cd1 = sig_cd(call->ContFail, fnc); - else - cd1 = sig_cd(ret_sig, fnc); - call->SigActs = new_sgact(sa->sig, cd1, call->SigActs); - } - continue; /* move on to next call */ - } - else if (contbody->OperName == NULL) { - /* - * The continuation simply calls another continuation. We can - * eliminate the intermediate continuation as long as we can - * move signal conversions to the other side of the operation. - * The operation only intercepts resume signals. - */ - collapse = 1; - for (sa = contbody->SigActs; sa != NULL; sa = sa->next) { - ret_sig = sa->cd->SigRef->sig; - if (sa->sig != ret_sig && (sa->sig == &resume || - ret_sig == &resume)) - collapse = 0; - } - if (collapse) { - if (--calledcont->ref_cnt != 0 && contbody->Cont != NULL) - ++contbody->Cont->ref_cnt; - call->Cont = contbody->Cont; - for (sa = contbody->SigActs; sa != NULL; sa = sa->next) { - ret_sig = sa->cd->SigRef->sig; - if (ret_sig != &resume) - call->SigActs = new_sgact(sa->sig, sig_cd(ret_sig, fnc), - call->SigActs); - } - continue; /* move on to next call */ - } - } - } - } - - /* - * We didn't do any optimizations. We must still figure out - * out how to handle signals returned by the continuation. - */ - if (calledcont != NULL) { - for (sl = calledcont->sig_lst; sl != NULL; sl = sl->next) { - if (sl->ref_cnt > 0) { - sig = sl->sig; - /* - * If an operation is being called, it handles failure from the - * continuation. - */ - if (sig != &resume || call->OperName == NULL) { - if (sig == &resume) - cd1 = sig_cd(call->ContFail, fnc); - else - cd1 = sig_cd(sig, fnc); - call->SigActs = new_sgact(sig, cd1, call->SigActs); - } - } - } - } - } - - /* - * fix up the signal handling in the functions implementing co-expressions. - */ - for (create = fnc->creatlst; create != NULL; create = create->NextCreat) - fix_fncs(create->Cont); - - if (!opt_cntrl) - return; /* control flow optimizations disabled. */ - /* - * Collapse branch chains and remove unreachable code. - */ - for (cd = &(fnc->cd); cd != NULL; cd = cd->next) { - switch (cd->cd_id) { - case C_CallSig: - no_break = 1; - for (sa = cd->SigActs; sa != NULL; sa = sa->next) { - if (sa->cd->cd_id == C_Break) { - switch (cd->next->cd_id) { - case C_Goto: - sa->cd->cd_id = cd->next->cd_id; - sa->cd->Lbl = cd->next->Lbl; - ++sa->cd->Lbl->RefCnt; - break; - case C_RetSig: - sa->cd->cd_id = cd->next->cd_id; - sa->cd->SigRef= cd->next->SigRef; - ++sa->cd->SigRef->ref_cnt; - break; - default: - no_break = 0; - } - } - if (sa->cd->cd_id == C_Goto) - clps_brch(sa->cd); - } - if (no_break) - rm_unrch(cd); - /* - * Try converting gotos into breaks. - */ - for (sa = cd->SigActs; sa != NULL; sa = sa->next) - if (sa->cd->cd_id == C_Goto) { - cd1 = cd->next; - while (cd1 != NULL && (cd1->cd_id == C_Label || - cd1->cd_id == C_RBrack)) { - if (cd1 == sa->cd->Lbl) { - sa->cd->cd_id = C_Break; - --cd1->RefCnt; - break; - } - cd1 = cd1->next; - } - } - break; - - case C_Goto: - clps_brch(cd); - rm_unrch(cd); - if (cd->cd_id == C_Goto) - ck_unneed(cd, cd->Lbl); - break; - - case C_If: - if (cd->ThenStmt->cd_id == C_Goto) { - clps_brch(cd->ThenStmt); - if (cd->ThenStmt->cd_id == C_Goto) - ck_unneed(cd, cd->ThenStmt->Lbl); - } - break; - - case C_PFail: - case C_PRet: - case C_RetSig: - rm_unrch(cd); - break; - } - } - - /* - * If this function only contains a return, indicate that we can - * call a shared signal returning function instead of it. This is - * a special case of "common subROUTINE elimination". - */ - if (fnc->cd.next->cd_id == C_RetSig) - fnc->flag |= CF_SigOnly; - } - -/* - * clps_brch - collapse branch chains. - */ -static void clps_brch(branch) -struct code *branch; - { - struct code *cd; - int save_id; - - cd = branch->Lbl->next; - while (cd->cd_id == C_Label) - cd = cd->next; - - /* - * Avoid infinite recursion on empty infinite loops. - */ - save_id = branch->cd_id; - branch->cd_id = 0; - if (cd->cd_id == C_Goto) - clps_brch(cd); - branch->cd_id = save_id; - - switch (cd->cd_id) { - case C_Goto: - --branch->Lbl->RefCnt; - ++cd->Lbl->RefCnt; - branch->Lbl = cd->Lbl; - break; - case C_RetSig: - /* - * This optimization requires that C_Goto have as many fields - * as C_RetSig. - */ - --branch->Lbl->RefCnt; - ++cd->SigRef->ref_cnt; - branch->cd_id = C_RetSig; - branch->SigRef = cd->SigRef; - break; - } - } - -/* - * rm_unrch - any code after the given point up to the next label is - * unreachable. Remove it. - */ -static void rm_unrch(cd) -struct code *cd; - { - struct code *cd1; - - for (cd1 = cd->next; cd1 != NULL && cd1->cd_id != C_LBrack && - (cd1->cd_id != C_Label || cd1->RefCnt == 0); cd1 = cd1->next) { - if (cd1->cd_id == C_RBrack) { - /* - * Continue deleting past a '}', but don't delete the '}' itself. - */ - cd->next = cd1; - cd1->prev = cd; - cd = cd1; - } - else - dec_refs(cd1); - } - cd->next = cd1; - if (cd1 != NULL) - cd1->prev = cd; - } - -/* - * dec_refs - decrement reference counts for things this code references. - */ -static void dec_refs(cd) -struct code *cd; - { - struct sig_act *sa; - - if (cd == NULL) - return; - switch (cd->cd_id) { - case C_Goto: - --cd->Lbl->RefCnt; - return; - case C_RetSig: - --cd->SigRef->ref_cnt; - return; - case C_CallSig: - if (cd->Cont != NULL) - --cd->Cont->ref_cnt; - for (sa = cd->SigActs; sa != NULL; sa = sa->next) - dec_refs(sa->cd); - return; - case C_If: - dec_refs(cd->ThenStmt); - return; - case C_Create: - --cd->Cont->ref_cnt; - return; - } - } - -/* - * ck_unneed - if there is nothing between a goto and its label, except - * perhaps other labels or '}', it is useless, so remove it. - */ -static struct code *ck_unneed(cd, lbl) -struct code *cd; -struct code *lbl; - { - struct code *cd1; - - cd1 = cd->next; - while (cd1 != NULL && (cd1->cd_id == C_Label || cd1->cd_id == C_RBrack)) { - if (cd1 == lbl) { - cd = cd->prev; - cd->next = cd->next->next; - cd->next->prev = cd; - --lbl->RefCnt; - break; - } - cd1 = cd1->next; - } - return cd; - } - diff --git a/src/iconc/incheck.c b/src/iconc/incheck.c deleted file mode 100644 index d4110f9..0000000 --- a/src/iconc/incheck.c +++ /dev/null @@ -1,802 +0,0 @@ -/* - * incheck.c - analyze a run-time operation using type information. - * Determine wither the operation can be in-lined and what kinds - * of parameter passing optimizations can be done. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "cglobals.h" -#include "csym.h" -#include "ctree.h" -#include "ccode.h" -#include "cproto.h" - -struct op_symentry *cur_symtab; /* symbol table for current operation */ - -/* - * Prototypes for static functions. - */ -static struct code *and_cond (struct code *cd1, struct code *cd2); -static int cnv_anlz (unsigned int typcd, struct il_code *src, - struct il_c *dflt, struct il_c *dest, - struct code **cdp); -static int defer_il (struct il_code *il); -static int if_anlz (struct il_code *il); -static void ilc_anlz (struct il_c *ilc); -static int il_anlz (struct il_code *il); -static void ret_anlz (struct il_c *ilc); -static int tc_anlz (struct il_code *il, int has_dflt); - -static int n_branches; /* number branches caused by run-time type checking */ -static int side_effect; /* abstract clause indicates side-effect */ -static int n_vararg; /* size of variable part of arg list to operation */ -static int n_susp; /* number of suspends */ -static int n_ret; /* number of returns */ - -/* - * do_inlin - determine if this operation can be in-lined at the current - * invocation. Also gather information about how arguments are used, - * and determine where the success continuation for the operation - * should be put. - */ -int do_inlin(impl, n, cont_loc, symtab, n_va) -struct implement *impl; -nodeptr n; -int *cont_loc; -struct op_symentry *symtab; -int n_va; - { - int nsyms; - int i; - - /* - * Copy arguments needed by other functions into globals and - * initialize flags and counters for information to be gathered - * during analysis. - */ - cur_symtyps = n->symtyps; /* mapping from arguments to types */ - cur_symtab = symtab; /* parameter info to be filled in */ - n_vararg = n_va; - n_branches = 0; - side_effect = 0; - n_susp = 0; - n_ret = 0; - - /* - * Analyze the code for this operation using type information for - * the arguments to the invocation. - */ - il_anlz(impl->in_line); - - - /* - * Don't in-line if there is more than one decision made based on - * run-time type checks (this is a heuristic). - */ - if (n_branches > 1) - return 0; - - /* - * If the operation (after eliminating code not used in this context) - * has one suspend and no returns, the "success continuation" can - * be placed in-line at the suspend site. Otherwise, any suspends - * require a separate function for the continuation. - */ - if (n_susp == 1 && n_ret == 0) - *cont_loc = SContIL; /* in-line continuation */ - else if (n_susp > 0) - *cont_loc = SepFnc; /* separate function for continuation */ - else - *cont_loc = EndOper; /* place "continuation" after the operation */ - - /* - * When an argument at the source level is an Icon variable, it is - * sometimes safe to use it directly in the generated code as the - * argument to the operation. However, it is NOT safe under the - * following conditions: - * - * - if the operation modifies the argument. - * - if the operation suspends and resumes so that intervening - * changes to the variable would be visible as changes to the - * argument. - * - if the operation has side effects that might involve the - * variable and be visible as changes to the argument. - */ - nsyms = (cur_symtyps == NULL ? 0 : cur_symtyps->nsyms); - for (i = 0; i < nsyms; ++i) - if (symtab[i].n_mods == 0 && n->intrnl_lftm == n && !side_effect) - symtab[i].var_safe = 1; - - return 1; - } - -/* - * il_anlz - analyze a piece of RTL code. Return an indication of - * whether execution can continue beyond it. - */ -static int il_anlz(il) -struct il_code *il; - { - int fall_thru; - int ncases; - int condition; - int indx; - int i, j; - - if (il == NULL) - return 1; - - switch (il->il_type) { - case IL_Const: /* should have been replaced by literal node */ - return 1; - - case IL_If1: - /* - * if-then statement. Determine whether the condition may - * succeed or fail. Analyze the then clause if needed. - */ - condition = if_anlz(il->u[0].fld); - fall_thru = 0; - if (condition & MaybeTrue) - fall_thru |= il_anlz(il->u[1].fld); - if (condition & MaybeFalse) - fall_thru = 1; - return fall_thru; - - case IL_If2: - /* - * if-then-else statement. Determine whether the condition may - * succeed or fail. Analyze the "then" clause and the "else" - * clause if needed. - */ - condition = if_anlz(il->u[0].fld); - fall_thru = 0; - if (condition & MaybeTrue) - fall_thru |= il_anlz(il->u[1].fld); - if (condition & MaybeFalse) - fall_thru |= il_anlz(il->u[2].fld); - return fall_thru; - - case IL_Tcase1: - /* - * type_case statement with no default clause. - */ - return tc_anlz(il, 0); - - case IL_Tcase2: - /* - * type_case statement with a default clause. - */ - return tc_anlz(il, 1); - - case IL_Lcase: - /* - * len_case statement. Determine which case matches the number - * of arguments. - */ - ncases = il->u[0].n; - indx = 1; - for (i = 0; i < ncases; ++i) { - if (il->u[indx++].n == n_vararg) /* selection number */ - return il_anlz(il->u[indx].fld); /* action */ - ++indx; - } - return il_anlz(il->u[indx].fld); /* default */ - - case IL_Acase: { - /* - * arith_case statement. - */ - struct il_code *var1; - struct il_code *var2; - int maybe_int; - int maybe_dbl; - int chk1; - int chk2; - - var1 = il->u[0].fld; - var2 = il->u[1].fld; - arth_anlz(var1, var2, &maybe_int, &maybe_dbl, &chk1, NULL, - &chk2, NULL); - - /* - * Analyze the selected case (note, large integer code is not - * currently in-lined and can be ignored). - */ - fall_thru = 0; - if (maybe_int) - fall_thru |= il_anlz(il->u[2].fld); /* C_integer action */ - if (maybe_dbl) - fall_thru |= il_anlz(il->u[4].fld); /* C_double action */ - return fall_thru; - } - - case IL_Err1: - /* - * runerr() with no offending value. - */ - return 0; - - case IL_Err2: - /* - * runerr() with an offending value. Note the reference to - * the offending value descriptor. - */ - indx = il->u[1].fld->u[0].n; /* symbol table index of variable */ - if (indx < cur_symtyps->nsyms) - ++cur_symtab[indx].n_refs; - return 0; - - case IL_Block: - /* - * inline {...} statement. - */ - i = il->u[1].n + 2; /* skip declaration stuff */ - ilc_anlz(il->u[i].c_cd); /* body of block */ - return il->u[0].n; - - case IL_Call: - /* - * call to body function. - */ - if (il->u[3].n & DoesSusp) - n_susp = 2; /* force continuation into separate function */ - - /* - * Analyze the C code for prototype parameter declarations - * and actual arguments. There are twice as many pieces of - * C code to look at as there are parameters. - */ - j = 2 * il->u[7].n; - i = 8; /* index of first piece of C code */ - while (j--) - ilc_anlz(il->u[i++].c_cd); - return ((il->u[3].n & DoesFThru) != 0); - - case IL_Lst: - /* - * Two consecutive pieces of RTL code. - */ - fall_thru = il_anlz(il->u[0].fld); - if (fall_thru) - fall_thru = il_anlz(il->u[1].fld); - return fall_thru; - - case IL_Abstr: - /* - * abstract type computation. See if it indicates side effects. - */ - if (il->u[0].fld != NULL) - side_effect = 1; - return 1; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(EXIT_FAILURE); - /* NOTREACHED */ - } - } - -/* - * if_anlz - analyze the condition of an if statement. - */ -static int if_anlz(il) -struct il_code *il; - { - int cond; - int cond1; - - if (il->il_type == IL_Bang) { - /* - * ! <condition>, negate the result of the condition - */ - cond1 = cond_anlz(il->u[0].fld, NULL); - cond = 0; - if (cond1 & MaybeTrue) - cond = MaybeFalse; - if (cond1 & MaybeFalse) - cond |= MaybeTrue; - } - else - cond = cond_anlz(il, NULL); - if (cond == (MaybeTrue | MaybeFalse)) - ++n_branches; /* must make a run-time decision */ - return cond; - } - -/* - * cond_anlz - analyze a simple condition or the conjunction of two - * conditions. If cdp is not NULL, use it to return a pointer code - * that implements the condition. - */ -int cond_anlz(il, cdp) -struct il_code *il; -struct code **cdp; - { - struct code *cd1; - struct code *cd2; - int cond1; - int cond2; - int indx; - - switch (il->il_type) { - case IL_And: - /* - * <cond> && <cond> - */ - cond1 = cond_anlz(il->u[0].fld, (cdp == NULL ? NULL : &cd1)); - if (cond1 & MaybeTrue) { - cond2 = cond_anlz(il->u[1].fld, (cdp == NULL ? NULL : &cd2)); - if (cdp != NULL) { - if (!(cond2 & MaybeTrue)) - *cdp = NULL; - else - *cdp = and_cond(cd1, cd2); - } - return (cond1 & MaybeFalse) | cond2; - } - else { - if (cdp != NULL) - *cdp = cd1; - return cond1; - } - - case IL_Cnv1: - /* - * cnv:<dest-type>(<source>) - */ - return cnv_anlz(il->u[0].n, il->u[1].fld, NULL, NULL, cdp); - - case IL_Cnv2: - /* - * cnv:<dest-type>(<source>,<destination>) - */ - return cnv_anlz(il->u[0].n, il->u[1].fld, NULL, il->u[2].c_cd, cdp); - - case IL_Def1: - /* - * def:<dest-type>(<source>,<default-value>) - */ - return cnv_anlz(il->u[0].n, il->u[1].fld, il->u[2].c_cd, NULL, cdp); - - case IL_Def2: - /* - * def:<dest-type>(<source>,<default-value>,<destination>) - */ - return cnv_anlz(il->u[0].n, il->u[1].fld, il->u[2].c_cd, il->u[3].c_cd, - cdp); - - case IL_Is: - /* - * is:<type-name>(<variable>) - */ - indx = il->u[1].fld->u[0].n; - cond1 = eval_is(il->u[0].n, indx); - if (cdp == NULL) { - if (indx < cur_symtyps->nsyms && cond1 == (MaybeTrue | MaybeFalse)) - ++cur_symtab[indx].n_refs; - } - else { - if (cond1 == (MaybeTrue | MaybeFalse)) - *cdp = typ_chk(il->u[1].fld, il->u[0].n); - else - *cdp = NULL; - } - return cond1; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(EXIT_FAILURE); - /* NOTREACHED */ - } - } - - -/* - * and_cond - construct && of two conditions, either of which may have - * been optimized away. - */ -static struct code *and_cond(cd1, cd2) -struct code *cd1; -struct code *cd2; - { - struct code *cd; - - if (cd1 == NULL) - return cd2; - else if (cd2 == NULL) - return cd1; - else { - cd = alc_ary(3); - cd->ElemTyp(0) = A_Ary; - cd->Array(0) = cd1; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " && "; - cd->ElemTyp(2) = A_Ary; - cd->Array(2) = cd2; - return cd; - } - } - -/* - * cnv_anlz - analyze a type conversion. Determine whether it can succeed - * and, if requested, produce code to perform the conversion. Also - * gather information about the variables it uses. - */ -static int cnv_anlz(typcd, src, dflt, dest, cdp) -unsigned int typcd; -struct il_code *src; -struct il_c *dflt; -struct il_c *dest; -struct code **cdp; - { - struct val_loc *src_loc; - int cond; - int cnv_flags; - int indx; - - /* - * Find out what is going on in the default and destination subexpressions. - * (The information is used elsewhere.) - */ - ilc_anlz(dflt); - ilc_anlz(dest); - - if (cdp != NULL) - *cdp = NULL; /* clear code pointer in case it is not set below */ - - /* - * Determine whether the conversion may succeed, whether it may fail, - * and whether it may actually convert a value or use the default - * value when it succeeds. - */ - indx = src->u[0].n; /* symbol table index for source of conversion */ - cond = eval_cnv(typcd, indx, dflt != NULL, &cnv_flags); - - /* - * Many optimizations are possible depending on whether a conversion - * is actually needed, whether type checking is needed, whether defaulting - * is done, and whether there is an explicit destination. Several - * optimizations are performed here; more may be added in the future. - */ - if (!(cnv_flags & MayDefault)) - dflt = NULL; /* demote defaulting to simple conversion */ - - if (cond & MaybeTrue) { - if (cnv_flags == MayKeep && dest == NULL) { - /* - * No type conversion, defaulting, or copying is needed. - */ - if (cond & MaybeFalse) { - /* - * A type check is needed. - */ - ++cur_symtab[indx].n_refs; /* non-modifying reference to source. */ - if (cdp != NULL) { - switch (typcd) { - case TypECInt: - *cdp = typ_chk(src, TypCInt); - break; - case TypEInt: - *cdp = typ_chk(src, int_typ); - break; - case TypTStr: - *cdp = typ_chk(src, str_typ); - break; - case TypTCset: - *cdp = typ_chk(src, cset_typ); - break; - default: - *cdp = typ_chk(src, typcd); - } - } - } - - if (cdp != NULL) { - /* - * Conversion from an integer to a C_integer can be done without - * any executable code; this is not considered a real conversion. - * It is accomplished by changing the symbol table so only the - * dword of the descriptor is accessed. - */ - switch (typcd) { - case TypCInt: - case TypECInt: - cur_symtab[indx].loc = loc_cpy(cur_symtab[indx].loc, M_CInt); - break; - } - } - } - else if (dest != NULL && cnv_flags == MayKeep && cond == MaybeTrue) { - /* - * There is an explicit destination, but no conversion, defaulting, - * or type checking is needed. Just copy the value to the - * destination. - */ - ++cur_symtab[indx].n_refs; /* non-modifying reference to source */ - if (cdp != NULL) { - src_loc = cur_symtab[indx].loc; - switch (typcd) { - case TypCInt: - case TypECInt: - /* - * The value is in the dword of the descriptor. - */ - src_loc = loc_cpy(src_loc, M_CInt); - break; - } - *cdp = il_copy(dest, src_loc); - } - } - else if (cnv_flags == MayDefault) { - /* - * The default value is used. - */ - if (dest == NULL) - ++cur_symtab[indx].n_mods; /* modifying reference */ - if (cdp != NULL) - *cdp = il_dflt(typcd, src, dflt, dest); - } - else { - /* - * Produce code to do the actual conversion. - * Determine whether the source location is being modified - * or just referenced. - */ - if (dest == NULL) { - /* - * "In place" conversion. - */ - switch (typcd) { - case TypCDbl: - case TypCInt: - case TypECInt: - /* - * not really converted in-place. - */ - ++cur_symtab[indx].n_refs; /* non-modifying reference */ - break; - default: - ++cur_symtab[indx].n_mods; /* modifying reference */ - } - } - else - ++cur_symtab[indx].n_refs; /* non-modifying reference */ - - if (cdp != NULL) - *cdp = il_cnv(typcd, src, dflt, dest); - } - } - return cond; - } - -/* - * ilc_anlz - gather information about in-line C code. - */ -static void ilc_anlz(ilc) -struct il_c *ilc; - { - while (ilc != NULL) { - switch(ilc->il_c_type) { - case ILC_Ref: - /* - * Non-modifying reference to variable - */ - if (ilc->n != RsltIndx) { - ++cur_symtab[ilc->n].n_refs; - } - break; - - case ILC_Mod: - /* - * Modifying reference to variable - */ - if (ilc->n != RsltIndx) { - ++cur_symtab[ilc->n].n_mods; - } - break; - - case ILC_Ret: - /* - * Return statement. - */ - ++n_ret; - ret_anlz(ilc); - break; - - case ILC_Susp: - /* - * Suspend statement. - */ - ++n_susp; - ret_anlz(ilc); - break; - - case ILC_CGto: - /* - * Conditional goto. - */ - ilc_anlz(ilc->code[0]); - break; - } - ilc = ilc->next; - } - } - -/* - * ret_anlz - gather information about the in-line C code associated - * with a return or suspend. - */ -static void ret_anlz(ilc) -struct il_c *ilc; - { - int i; - int j; - - /* - * See if the code is simply returning a parameter. - */ - if (ilc->n == RetDesc && ilc->code[0]->il_c_type == ILC_Ref && - ilc->code[0]->next == NULL) { - j = ilc->code[0]->n; - ++cur_symtab[j].n_refs; - ++cur_symtab[j].n_rets; - } - else { - for (i = 0; i < 3 && ilc->code[i] != NULL; ++i) - ilc_anlz(ilc->code[i]); - } - } - -/* - * deref_il - dummy routine to pass to a code walk. - */ -/*ARGSUSED*/ -static int defer_il(il) -struct il_code *il; - { - /* - * Called for each case in a type_case statement that might be selected. - * However, the actual analysis of the case, if it is needed, - * is done elsewhere, so just return. - */ - return 0; - } - -/* - * findcases - determine how many cases of an type_case statement may - * be true. If there are two or less, determine the "if" statement - * that can be used (if there are more than two, the code is not - * in-lined). - */ -void findcases(il, has_dflt, case_anlz) -struct il_code *il; -int has_dflt; -struct case_anlz *case_anlz; - { - int i; - - case_anlz->n_cases = 0; - case_anlz->typcd = -1; - case_anlz->il_then = NULL; - case_anlz->il_else = NULL; - i = type_case(il, defer_il, case_anlz); - /* - * See if the explicit cases have accounted for all possible - * types that might be present. - */ - if (i == -1) { /* all types accounted for */ - if (case_anlz->il_else == NULL && case_anlz->il_then != NULL) { - /* - * We don't need to actually check the type. - */ - case_anlz->il_else = case_anlz->il_then; - case_anlz->il_then = NULL; - case_anlz->typcd = -1; - } - } - else { /* not all types accounted for */ - if (case_anlz->il_else != NULL) - case_anlz->n_cases = 3; /* force no inlining */ - else if (has_dflt) - case_anlz->il_else = il->u[i].fld; /* default */ - } - - if (case_anlz->n_cases > 2) - n_branches = 2; /* no in-lining */ - else if (case_anlz->il_then != NULL) - ++n_branches; - } - - -/* - * tc_anlz - analyze a type_case statement. It is only of interest for - * in-lining if it can be reduced to an "if" statement or an - * unconditional statement. - */ -static int tc_anlz(il, has_dflt) -struct il_code *il; -int has_dflt; - { - struct case_anlz case_anlz; - int fall_thru; - int indx; - - findcases(il, has_dflt, &case_anlz); - - if (case_anlz.il_else == NULL) - fall_thru = 1; /* either no code at all or condition with no "else" */ - else - fall_thru = 0; /* either unconditional or if-then-else: check code */ - - if (case_anlz.il_then != NULL) { - fall_thru |= il_anlz(case_anlz.il_then); - indx = il->u[0].fld->u[0].n; /* symbol table index of variable */ - if (indx < cur_symtyps->nsyms) - ++cur_symtab[indx].n_refs; - } - if (case_anlz.il_else != NULL) - fall_thru |= il_anlz(case_anlz.il_else); - return fall_thru; - } - -/* - * arth_anlz - analyze the type checking of an arith_case statement. - */ -void arth_anlz(var1, var2, maybe_int, maybe_dbl, chk1, conv1p, chk2, conv2p) -struct il_code *var1; -struct il_code *var2; -int *maybe_int; -int *maybe_dbl; -int *chk1; -struct code **conv1p; -int *chk2; -struct code **conv2p; - { - int cond; - int cnv_typ; - - - /* - * First do an analysis to find out which cases are needed. This is - * more accurate than analysing the conversions separately, but does - * not get all the information we need. - */ - eval_arith(var1->u[0].n, var2->u[0].n, maybe_int, maybe_dbl); - - if (*maybe_int & (largeints | *maybe_dbl)) { - /* - * Too much type checking; don't bother with these cases. Force no - * in-lining. - */ - n_branches += 2; - } - else { - if (*maybe_int) - cnv_typ = TypCInt; - else - cnv_typ = TypCDbl; - - /* - * See exactly what kinds of conversions/type checks are needed and, - * if requested, generate code for them. - */ - *chk1 = 0; - *chk2 = 0; - - cond = cnv_anlz(cnv_typ, var1, NULL, NULL, conv1p); - if (cond & MaybeFalse) { - ++n_branches; /* run-time decision */ - *chk1 = 1; - if (var1->u[0].n < cur_symtyps->nsyms) - ++cur_symtab[var1->u[0].n].n_refs; /* used in runerr2() */ - } - cond = cnv_anlz(cnv_typ, var2, NULL, NULL, conv2p); - if (cond & MaybeFalse) { - ++n_branches; /* run-time decision */ - *chk2 = 1; - if (var2->u[0].n < cur_symtyps->nsyms) - ++cur_symtab[var2->u[0].n].n_refs; /* used in runerr2() */ - } - } - } diff --git a/src/iconc/inline.c b/src/iconc/inline.c deleted file mode 100644 index 234229c..0000000 --- a/src/iconc/inline.c +++ /dev/null @@ -1,2007 +0,0 @@ -/* - * inline.c - routines to put run-time routines in-line. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "ccode.h" -#include "csym.h" -#include "ctree.h" -#include "cproto.h" -#include "cglobals.h" - -/* - * Prototypes for static functions. - */ -static void arth_arg ( struct il_code *var, - struct val_loc *v_orig, int chk, - struct code *cnv); -static int body_fnc (struct il_code *il); -static void chkforblk (void); -static void cnv_dest (int loc, int is_cstr, - struct il_code *src, int sym_indx, - struct il_c *dest, struct code *cd, int i); -static void dwrd_asgn (struct val_loc *vloc, char *typ); -static struct il_c *line_ilc (struct il_c *ilc); -static int gen_if (struct code *cond_cd, - struct il_code *il_then, - struct il_code *il_else, - struct val_loc **locs); -static int gen_il (struct il_code *il); -static void gen_ilc (struct il_c *il); -static void gen_ilret (struct il_c *ilc); -static int gen_tcase (struct il_code *il, int has_dflt); -static void il_var (struct il_code *il, struct code *cd, - int indx); -static void mrg_locs (struct val_loc **locs); -static struct code *oper_lbl (char *s); -static void part_asgn (struct val_loc *vloc, char *asgn, - struct il_c *value); -static void rstr_locs (struct val_loc **locs); -static struct val_loc **sav_locs (void); -static void sub_ilc (struct il_c *ilc, struct code *cd, int indx); - -/* - * There are many parameters that are shared by multiple routines. There - * are copied into statics. - */ -static struct val_loc *rslt; /* result location */ -static struct code **scont_strt; /* label following operation code */ -static struct code **scont_fail; /* resumption label for in-line suspend */ -static struct c_fnc *cont; /* success continuation */ -static struct implement *impl; /* data base entry for operation */ -static int nsyms; /* number symbols in operation symbol table */ -static int n_vararg; /* size of variable part of arg list */ -static nodeptr intrnl_lftm; /* lifetime of internal variables */ -static struct val_loc **tended; /* array of tended locals */ - -/* - * gen_inlin - generate in-line code for an operation. - */ -void gen_inlin(il, r, strt, fail, c, ip, ns, st, n, dcl_var, n_va) -struct il_code *il; -struct val_loc *r; -struct code **strt; -struct code **fail; -struct c_fnc *c; -struct implement *ip; -int ns; -struct op_symentry *st; -nodeptr n; -int dcl_var; -int n_va; - { - struct code *cd; - struct val_loc *tnd; - int i; - - /* - * Copy arguments in to globals. - */ - rslt = r; - scont_strt = strt; - scont_fail = fail; - cont = c; - impl = ip; - nsyms = ns; - cur_symtab = st; - intrnl_lftm = n->intrnl_lftm; - cur_symtyps = n->symtyps; - n_vararg = n_va; - - /* - * Generate code to initialize local tended descriptors and determine - * how to access the descriptors. - */ - for (i = 0; i < impl->ntnds; ++i) { - if (cur_symtab[dcl_var].n_refs + cur_symtab[dcl_var].n_mods > 0) { - tnd = chk_alc(NULL, n->intrnl_lftm); - switch (impl->tnds[i].var_type) { - case TndDesc: - cur_symtab[dcl_var].loc = tnd; - break; - case TndStr: - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = tnd; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = emptystr;"; - cd_add(cd); - cur_symtab[dcl_var].loc = loc_cpy(tnd, M_CharPtr); - break; - case TndBlk: - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = tnd; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = nullptr;"; - cd_add(cd); - cur_symtab[dcl_var].loc = loc_cpy(tnd, M_BlkPtr); - cur_symtab[dcl_var].loc->blk_name = impl->tnds[i].blk_name; - break; - } - if (impl->tnds[i].init != NULL) { - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = cur_symtab[dcl_var].loc; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = "; - sub_ilc(impl->tnds[i].init, cd, 2); - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ";"; - cd_add(cd); - } - } - ++dcl_var; - } - - /* - * If there are local non-tended variables, generate code for the - * declarations, placing everything in braces. - */ - if (impl->nvars > 0) { - cd = NewCode(0); - cd->cd_id = C_LBrack; /* { */ - cd_add(cd); - for (i = 0; i < impl->nvars; ++i) { - if (cur_symtab[dcl_var].n_refs + cur_symtab[dcl_var].n_mods > 0) { - gen_ilc(impl->vars[i].dcl); - cur_symtab[dcl_var].loc = cvar_loc(impl->vars[i].name); - } - ++dcl_var; - } - } - - gen_il(il); /* generate executable code */ - - if (impl->nvars > 0) { - cd = NewCode(0); - cd->cd_id = C_RBrack; /* } */ - cd_add(cd); - } - } - -/* - * gen_il - generate code from a sub-tree of in-line code from the data - * base. Determine if execution can continue past this code. - * - */ -static int gen_il(il) -struct il_code *il; - { - struct code *cd; - struct code *cd1; - struct il_code *il_cond; - struct il_code *il_then; - struct il_code *il_else; - struct il_code *il_t; - struct val_loc **locs; - struct val_loc **locs1; - struct val_loc *tnd; - int fall_thru; - int cond; - int ncases; - int indx; - int ntended; - int i; - - if (il == NULL) - return 1; - - switch (il->il_type) { - case IL_Const: /* should have been replaced by literal node */ - return 1; - - case IL_If1: - case IL_If2: - /* - * if-then or if-then-else statement. - */ - il_then = il->u[1].fld; - if (il->il_type == IL_If2) - il_else = il->u[2].fld; - else - il_else = NULL; - il_cond = il->u[0].fld; - if (il->u[0].fld->il_type == IL_Bang) { - il_cond = il_cond->u[0].fld; - il_t = il_then; - il_then = il_else; - il_else = il_t; - } - locs = sav_locs(); - cond = cond_anlz(il_cond, &cd1); - if (cond == (MaybeTrue | MaybeFalse)) - fall_thru = gen_if(cd1, il_then, il_else, locs); - else { - if (cd1 != NULL) { - cd_add(cd1); /* condition contains needed conversions */ - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = ";"; - cd_add(cd); - } - if (cond == MaybeTrue) - fall_thru = gen_il(il_then); - else if (cond == MaybeFalse) { - locs1 = sav_locs(); - rstr_locs(locs); - locs = locs1; - fall_thru = gen_il(il_else); - } - mrg_locs(locs); - } - return fall_thru; - - case IL_Tcase1: - /* - * type_case statement with no default clause. - */ - return gen_tcase(il, 0); - - case IL_Tcase2: - /* - * type_case statement with a default clause. - */ - return gen_tcase(il, 1); - - case IL_Lcase: - /* - * len_case statement. Determine which case matches the number - * of arguments. - */ - ncases = il->u[0].n; - indx = 1; - for (i = 0; i < ncases; ++i) { - if (il->u[indx++].n == n_vararg) /* selection number */ - return gen_il(il->u[indx].fld); /* action */ - ++indx; - } - return gen_il(il->u[indx].fld); /* default */ - - case IL_Acase: { - /* - * arith_case statement. - */ - struct il_code *var1; - struct il_code *var2; - struct val_loc *v_orig1; - struct val_loc *v_orig2; - struct code *cnv1; - struct code *cnv2; - int maybe_int; - int maybe_dbl; - int chk1; - int chk2; - - var1 = il->u[0].fld; - var2 = il->u[1].fld; - v_orig1 = cur_symtab[var1->u[0].n].loc; /* remember for error msgs */ - v_orig2 = cur_symtab[var2->u[0].n].loc; /* remember for error msgs */ - arth_anlz(var1, var2, &maybe_int, &maybe_dbl, &chk1, &cnv1, - &chk2, &cnv2); - - /* - * This statement is in-lined if there is only C integer - * arithmetic, only C double arithmetic, or only a run-time - * error. - */ - arth_arg(var1, v_orig1, chk1, cnv1); - arth_arg(var2, v_orig2, chk2, cnv2); - if (maybe_int) - return gen_il(il->u[2].fld); /* C_integer action */ - else if (maybe_dbl) - return gen_il(il->u[4].fld); /* C_double action */ - else - return 0; - } - - case IL_Err1: - /* - * runerr() with no offending value. - */ - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg("; - cd->ElemTyp(1) = A_Intgr; - cd->Intgr(1) = il->u[0].n; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", NULL);"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - for (i = 0; i < nsyms; ++i) - cur_symtab[i].loc = NULL; - return 0; - - case IL_Err2: - /* - * runerr() with an offending value. Note the reference to - * the offending value descriptor. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg("; - cd->ElemTyp(1) = A_Intgr; - cd->Intgr(1) = il->u[0].n; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", &("; - il_var(il->u[1].fld, cd, 3); - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "));"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - for (i = 0; i < nsyms; ++i) - cur_symtab[i].loc = NULL; - return 0; - - case IL_Lst: - /* - * Two consecutive pieces of RTL code. - */ - fall_thru = gen_il(il->u[0].fld); - if (fall_thru) - fall_thru = gen_il(il->u[1].fld); - return fall_thru; - - case IL_Block: - /* - * inline {...} statement. - * - * Allocate and initialize any tended locals. - */ - ntended = il->u[1].n; - if (ntended > 0) - tended = (struct val_loc **)alloc((unsigned int) - sizeof(struct val_loc *) * ntended); - for (i = 2; i - 2 < ntended; ++i) { - tnd = chk_alc(NULL, intrnl_lftm); - tended[i - 2] = tnd; - switch (il->u[i].n) { - case TndDesc: - break; - case TndStr: - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = tnd; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = emptystr;"; - cd_add(cd); - break; - case TndBlk: - cd = alc_ary(2); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = tnd; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = " = nullptr;"; - cd_add(cd); - break; - } - } - gen_ilc(il->u[i].c_cd); /* body of block */ - /* - * See if execution can fall through this code. - */ - if (il->u[0].n) - return 1; - else { - for (i = 0; i < nsyms; ++i) - cur_symtab[i].loc = NULL; - return 0; - } - - case IL_Call: - /* - * call to body function. - */ - return body_fnc(il); - - case IL_Abstr: - /* - * abstract type computation. Only used by type inference. - */ - return 1; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(1); - /* NOTREACHED */ - } - } - -/* - * arth_arg - in-line code to check a conversion for an arith_case statement. - */ -static void arth_arg(var, v_orig, chk, cnv) -struct il_code *var; -struct val_loc *v_orig; -int chk; -struct code *cnv; - { - struct code *lbl; - struct code *cd; - - if (chk) { - /* - * Must check the conversion. - */ - lbl = oper_lbl("converted"); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - if (cnv != NULL) { - cd = NewCode(2); - cd->cd_id = C_If; - cd->Cond = cnv; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - } - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(102, &("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = v_orig; /* var location before conversion */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = "));"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - else if (cnv != NULL) { - cd_add(cnv); /* conversion cannot fail */ - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = ";"; - cd_add(cd); - } - } - -/* - * body_fnc - generate code to call a body function. - */ -static int body_fnc(il) -struct il_code *il; - { - struct code *arg_lst; - struct code *cd; - struct c_fnc *cont1; - char *oper_nm; - int ret_val; - int ret_flag; - int need_rslt; - int num_sbuf; - int num_cbuf; - int expl_args; - int arglst_sz; /* size of arg list in number of code pieces */ - int il_indx; - int cd_indx; - int proto_prt; - int i; - - /* - * Determine if a function prototype has been printed yet for this - * body function. - */ - proto_prt = il->u[0].n; - il->u[0].n = 1; - - /* - * Construct the name of the body function. - */ - oper_nm = (char *)alloc((unsigned int)(strlen(impl->name) + 6)); - sprintf(oper_nm, "%c%c%c%c_%s", impl->oper_typ, impl->prefix[0], - impl->prefix[1], (char)il->u[1].n, impl->name); - - /* - * Extract from the call the flags and other information describing - * the function, then use this information to deduce the arguments - * needed by the function. - */ - ret_val = il->u[2].n; - ret_flag = il->u[3].n; - need_rslt = il->u[4].n; - num_sbuf = il->u[5].n; - num_cbuf = il->u[6].n; - expl_args = il->u[7].n; - - /* - * determine how large the argument list is. - */ - arglst_sz = 2 * expl_args - 1; - if (num_sbuf > 0) - arglst_sz += 3; - if (num_cbuf > 0) - arglst_sz += 2; - if (need_rslt) - arglst_sz += 3; - if (arglst_sz > 0) - arg_lst = alc_ary(arglst_sz); - else - arg_lst = alc_ary(0); - - if (!proto_prt) { - /* - * Determine whether the body function returns a C integer, double, - * no value, or a signal. - */ - switch (ret_val) { - case RetInt: - fprintf(inclfile, "C_integer %s (", oper_nm); - break; - case RetDbl: - fprintf(inclfile, "double %s (", oper_nm); - break; - case RetNoVal: - fprintf(inclfile, "void %s (", oper_nm); - break; - case RetSig: - fprintf(inclfile, "int %s (", oper_nm); - break; - } - } - - /* - * Produce prototype and code for the explicit arguments in the - * function call. Note that the call entry contains C code for both. - */ - il_indx = 8; - cd_indx = 0; - while (expl_args--) { - if (cd_indx > 0) { - /* - * Not first entry, precede by ','. - */ - arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ - arg_lst->Str(cd_indx) = ", "; - if (!proto_prt) - fprintf(inclfile, ", "); - ++cd_indx; - } - if (!proto_prt) - fprintf(inclfile, "%s", il->u[il_indx].c_cd->s); /* parameter dcl */ - ++il_indx; - sub_ilc(il->u[il_indx++].c_cd, arg_lst, cd_indx++); - } - - /* - * If string buffers are needed, allocate them and pass pointer to - * function. - */ - if (num_sbuf > 0) { - if (cd_indx > 0) { - /* - * Not first entry, precede by ','. - */ - arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ - arg_lst->Str(cd_indx) = ", "; - if (!proto_prt) - fprintf(inclfile, ", "); - ++cd_indx; - } - arg_lst->ElemTyp(cd_indx) = A_Str; - arg_lst->Str(cd_indx) = "(char (*)[MaxCvtLen])"; - ++cd_indx; - arg_lst->ElemTyp(cd_indx) = A_SBuf; - arg_lst->Intgr(cd_indx) = alc_sbufs(num_sbuf, intrnl_lftm); - if (!proto_prt) - fprintf(inclfile, "char (*r_sbuf)[MaxCvtLen]"); - ++cd_indx; - } - - /* - * If cset buffers are needed, allocate them and pass pointer to - * function. - */ - if (num_cbuf > 0) { - if (cd_indx > 0) { - /* - * Not first entry, precede by ','. - */ - arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ - arg_lst->Str(cd_indx) = ", "; - if (!proto_prt) - fprintf(inclfile, ", "); - ++cd_indx; - } - arg_lst->ElemTyp(cd_indx) = A_CBuf; - arg_lst->Intgr(cd_indx) = alc_cbufs(num_cbuf, intrnl_lftm); - if (!proto_prt) - fprintf(inclfile, "struct b_cset *r_cbuf"); - ++cd_indx; - } - - /* - * See if the function needs a pointer to the result location - * of the operation. - */ - if (need_rslt) { - if (cd_indx > 0) { - /* - * Not first entry, precede by ','. - */ - arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ - arg_lst->Str(cd_indx) = ", "; - if (!proto_prt) - fprintf(inclfile, ", "); - ++cd_indx; - } - arg_lst->ElemTyp(cd_indx) = A_Str; /* location of result */ - arg_lst->Str(cd_indx) = "&"; - ++cd_indx; - arg_lst->ElemTyp(cd_indx) = A_ValLoc; - arg_lst->ValLoc(cd_indx) = rslt; - if (!proto_prt) - fprintf(inclfile, "dptr rslt"); - ++cd_indx; - } - - if (!proto_prt) { - /* - * The last possible argument is the success continuation. - * If there are no arguments, indicate this in the prototype. - */ - if (ret_flag & DoesSusp) { - if (cd_indx > 0) - fprintf(inclfile, ", "); - fprintf(inclfile, "continuation succ_cont"); - } - else if (cd_indx == 0) - fprintf(inclfile, "void"); - fprintf(inclfile, ");\n"); - } - - /* - * Does this call need the success continuation for the operation. - */ - if (ret_flag & DoesSusp) - cont1 = cont; - else - cont1 = NULL; - - switch (ret_val) { - case RetInt: - /* - * The body function returns a C integer. - */ - cd = alc_ary(6); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".vword.integr = "; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = oper_nm; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "("; - cd->ElemTyp(4) = A_Ary; - cd->Array(4) = arg_lst; - cd->ElemTyp(5) = A_Str; - cd->Str(5) = ");"; - cd_add(cd); - dwrd_asgn(rslt, "Integer"); - cd_add(mk_goto(*scont_strt)); - break; - case RetDbl: - /* - * The body function returns a C double. - */ - cd = alc_ary(6); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".vword.bptr = (union block *)alcreal("; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = oper_nm; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "("; - cd->ElemTyp(4) = A_Ary; - cd->Array(4) = arg_lst; - cd->ElemTyp(5) = A_Str; - cd->Str(5) = "));"; - cd_add(cd); - dwrd_asgn(rslt, "Real"); - chkforblk(); /* make sure the block allocation succeeded */ - cd_add(mk_goto(*scont_strt)); - break; - case RetNoVal: - /* - * The body function does not directly return a value. - */ - cd = alc_ary(4); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = oper_nm; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = "("; - cd->ElemTyp(2) = A_Ary; - cd->Array(2) = arg_lst; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ");"; - cd_add(cd); - if (ret_flag & DoesFail | (err_conv && (ret_flag & DoesEFail))) - cd_add(sig_cd(on_failure, cur_fnc)); - else if (ret_flag & DoesRet) - cd_add(mk_goto(*scont_strt)); - break; - case RetSig: - /* - * The body function returns a signal. - */ - callo_add(oper_nm, ret_flag, cont1, 0, arg_lst, mk_goto(*scont_strt)); - break; - } - /* - * See if execution can fall through this call. - */ - if (ret_flag & DoesFThru) - return 1; - else { - for (i = 0; i < nsyms; ++i) - cur_symtab[i].loc = NULL; - return 0; - } - } - - -/* - * il_var - generate code for a possibly subscripted variable into - * an element of a code array. - */ -static void il_var(il, cd, indx) -struct il_code *il; -struct code *cd; -int indx; - { - struct code *cd1; - - if (il->il_type == IL_Subscr) { - /* - * Subscripted variable. - */ - cd1 = cd; - cd = alc_ary(4); - cd1->ElemTyp(indx) = A_Ary; - cd1->Array(indx) = cd; - indx = 0; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = "["; - cd->ElemTyp(2) = A_Intgr; - cd->Intgr(2) = il->u[1].n; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = "]"; - } - - /* - * See if this is the result location of the operation or an ordinary - * variable. - */ - cd->ElemTyp(indx) = A_ValLoc; - if (il->u[0].n == RsltIndx) - cd->ValLoc(indx) = rslt; - else - cd->ValLoc(indx) = cur_symtab[il->u[0].n].loc; - } - -/* - * part_asgn - generate code for an assignment to (part of) a descriptor. - */ -static void part_asgn(vloc, asgn, value) -struct val_loc *vloc; -char *asgn; -struct il_c *value; - { - struct code *cd; - - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = vloc; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = asgn; - sub_ilc(value, cd, 2); /* value */ - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ";"; - cd_add(cd); - } - -/* - * dwrd_asgn - generate code to assign a type code to the dword of a descriptor. - */ -static void dwrd_asgn(vloc, typ) -struct val_loc *vloc; -char *typ; - { - struct code *cd; - - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = vloc; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".dword = D_"; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = typ; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ";"; - cd_add(cd); - } - -/* - * sub_ilc - generate code from a sequence of C code and place it - * in a slot in a code array. - */ -static void sub_ilc(ilc, cd, indx) -struct il_c *ilc; -struct code *cd; -int indx; - { - struct il_c *ilc1; - struct code *cd1; - int n; - - /* - * Count the number of pieces of C code to process. - */ - n = 0; - for (ilc1 = ilc; ilc1 != NULL; ilc1 = ilc1->next) - ++n; - - /* - * If there is only one piece of code, place it directly in the - * slot of the array. Otherwise allocate a sub-array and place it - * in the slot. - */ - if (n > 1) { - cd1 = cd; - cd = alc_ary(n); - cd1->ElemTyp(indx) = A_Ary; - cd1->Array(indx) = cd; - indx = 0; - } - - while (ilc != NULL) { - switch (ilc->il_c_type) { - case ILC_Ref: - case ILC_Mod: - /* - * Reference to variable in symbol table. - */ - cd->ElemTyp(indx) = A_ValLoc; - if (ilc->n == RsltIndx) - cd->ValLoc(indx) = rslt; - else { - if (ilc->s == NULL) - cd->ValLoc(indx) = cur_symtab[ilc->n].loc; - else { - /* - * Access the entire descriptor. - */ - cd->ValLoc(indx) = loc_cpy(cur_symtab[ilc->n].loc, M_None); - } - } - break; - - case ILC_Tend: - /* - * Reference to a tended variable. - */ - cd->ElemTyp(indx) = A_ValLoc; - cd->ValLoc(indx) = tended[ilc->n]; - break; - - case ILC_Str: - /* - * String representing C code. - */ - cd->ElemTyp(indx) = A_Str; - cd->Str(indx) = ilc->s; - break; - - case ILC_SBuf: - /* - * String buffer for a conversion. - */ - cd->ElemTyp(indx) = A_SBuf; - cd->Intgr(indx) = alc_sbufs(1, intrnl_lftm); - break; - - case ILC_CBuf: - /* - * Cset buffer for a conversion. - */ - cd->ElemTyp(indx) = A_CBuf; - cd->Intgr(indx) = alc_cbufs(1, intrnl_lftm); - break; - - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(1); - } - ilc = ilc->next; - ++indx; - } - - } - -/* - * gen_ilret - generate code to set the result value from a suspend or - * return. - */ -static void gen_ilret(ilc) -struct il_c *ilc; - { - struct il_c *ilc0; - struct code *cd; - char *cap_id; - int typcd; - - if (rslt == &ignore) - return; /* Don't bother computing the result; it's never used */ - - ilc0 = ilc->code[0]; - typcd = ilc->n; - - if (typcd < 0) { - /* - * RTL returns that do not look like function calls to standard Icon - * type name. - */ - switch (typcd) { - case TypCInt: - /* - * return/suspend C_integer <expr>; - */ - part_asgn(rslt, ".vword.integr = ", ilc0); - dwrd_asgn(rslt, "Integer"); - break; - case TypCDbl: - /* - * return/suspend C_double <expr>; - */ - cd = alc_ary(4); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".vword.bptr = (union block *)alcreal("; - sub_ilc(ilc0, cd, 2); /* value */ - cd->ElemTyp(3) = A_Str; - cd->Str(3) = ");"; - cd_add(cd); - dwrd_asgn(rslt, "Real"); - chkforblk(); /* make sure the block allocation succeeded */ - break; - case TypCStr: - /* - * return/suspend C_string <expr>; - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "AsgnCStr("; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", "; - sub_ilc(ilc0, cd, 3); /* <expr> */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ");"; - cd_add(cd); - break; - case RetDesc: - /* - * return/suspend <expr>; - */ - part_asgn(rslt, " = ", ilc0); - break; - case RetNVar: - /* - * return/suspend named_var(<desc-pntr>); - */ - part_asgn(rslt, ".vword.descptr = ", ilc0); - dwrd_asgn(rslt, "Var"); - break; - case RetSVar: - /* - * return/suspend struct_var(<desc-pntr>, <block_pntr>); - */ - part_asgn(rslt, ".vword.descptr = (dptr)", ilc->code[1]); - cd = alc_ary(6); - cd->ElemTyp(0) = A_ValLoc; - cd->ValLoc(0) = rslt; - cd->ElemTyp(1) = A_Str; - cd->Str(1) = ".dword = D_Var + ((word *)"; - sub_ilc(ilc0, cd, 2); /* value */ - cd->ElemTyp(3) = A_Str; - cd->Str(3) = " - (word *)"; - cd->ElemTyp(4) = A_ValLoc; - cd->ValLoc(4) = rslt; - cd->ElemTyp(5) = A_Str; - cd->Str(5) = ".vword.descptr);"; - cd_add(cd); - break; - case RetNone: - /* - * return/suspend result; - * - * Result already set, do nothing. - */ - break; - default: - fprintf(stderr, - "compiler error: unknown RLT return in data base\n"); - exit(1); - /* NOTREACHED */ - } - } - else { - /* - * RTL returns that look like function calls to standard Icon type - * names. - */ - cap_id = icontypes[typcd].cap_id; - switch (icontypes[typcd].rtl_ret) { - case TRetBlkP: - /* - * return/suspend <type>(<block-pntr>); - */ - part_asgn(rslt, ".vword.bptr = (union block *)", ilc0); - dwrd_asgn(rslt, cap_id); - break; - case TRetDescP: - /* - * return/suspend <type>(<descriptor-pntr>); - */ - part_asgn(rslt, ".vword.descptr = (dptr)", ilc0); - dwrd_asgn(rslt, cap_id); - break; - case TRetCharP: - /* - * return/suspend <type>(<char-pntr>); - */ - part_asgn(rslt, ".vword.sptr = (char *)", ilc0); - dwrd_asgn(rslt, cap_id); - break; - case TRetCInt: - /* - * return/suspend <type>(<integer>); - */ - part_asgn(rslt, ".vword.integr = (word)", ilc0); - dwrd_asgn(rslt, cap_id); - break; - case TRetSpcl: - /* - * RTL returns that look like function calls to standard type - * names but take more than one argument. - */ - if (typcd == str_typ) { - /* - * return/suspend string(<len>, <char-pntr>); - */ - part_asgn(rslt, ".vword.sptr = ", ilc->code[1]); - part_asgn(rslt, ".dword = ", ilc0); - } - else if (typcd == stv_typ) { - /* - * return/suspend substr(<desc-pntr>, <start>, <len>); - */ - cd = alc_ary(9); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "SubStr(&"; - cd->ElemTyp(1) = A_ValLoc; - cd->ValLoc(1) = rslt; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", "; - sub_ilc(ilc0, cd, 3); - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", "; - sub_ilc(ilc->code[2], cd, 5); - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ", "; - sub_ilc(ilc->code[1], cd, 7); - cd->ElemTyp(8) = A_Str; - cd->Str(8) = ");"; - cd_add(cd); - chkforblk(); /* make sure the block allocation succeeded */ - } - else { - fprintf(stderr, - "compiler error: unknown RLT return in data base\n"); - exit(1); - /* NOTREACHED */ - } - break; - default: - fprintf(stderr, - "compiler error: unknown RLT return in data base\n"); - exit(1); - /* NOTREACHED */ - } - } - } - -/* - * chkforblk - generate code to make sure the allocation of a block - * for the result descriptor was successful. - */ -static void chkforblk() - { - struct code *cd; - struct code *cd1; - struct code *lbl; - - lbl = alc_lbl("got allocation", 0); - cd_add(lbl); - cur_fnc->cursor = lbl->prev; /* code goes before label */ - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "("; - cd1->ElemTyp(1) = A_ValLoc; - cd1->ValLoc(1) = rslt; - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ").vword.bptr != NULL"; - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbl); - cd_add(cd); - cd = alc_ary(1); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "err_msg(307, NULL);"; - cd_add(cd); - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - cur_fnc->cursor = lbl; - } - -/* - * gen_ilc - generate code for an sequence of in-line C code. - */ -static void gen_ilc(ilc) -struct il_c *ilc; - { - struct il_c *ilc1; - struct code *cd; - struct code *cd1; - struct code *lbl1; - struct code *fail_sav; - struct code **lbls; - int max_lbl; - int i; - - /* - * Determine how many labels there are in the code and allocate an - * array to map from label numbers to labels in the code. - */ - max_lbl = -1; - for (ilc1 = ilc; ilc1 != NULL; ilc1 = ilc1->next) { - switch(ilc1->il_c_type) { - case ILC_CGto: - case ILC_Goto: - case ILC_Lbl: - if (ilc1->n > max_lbl) - max_lbl = ilc1->n; - } - } - ++max_lbl; /* adjust for 0 indexing */ - if (max_lbl > 0) { - lbls = (struct code **)alloc((unsigned int) sizeof(struct code *) * - max_lbl); - for (i = 0; i < max_lbl; ++i) - lbls[i] = NULL; - } - - while (ilc != NULL) { - switch(ilc->il_c_type) { - case ILC_Ref: - case ILC_Mod: - case ILC_Tend: - case ILC_SBuf: - case ILC_CBuf: - case ILC_Str: - /* - * The beginning of a sequence of code fragments that can be - * place on one line. - */ - ilc = line_ilc(ilc); - break; - - case ILC_Fail: - /* - * fail - perform failure action. - */ - cd_add(sig_cd(on_failure, cur_fnc)); - break; - - case ILC_EFail: - /* - * errorfail - same as fail if error conversion is supported. - */ - if (err_conv) - cd_add(sig_cd(on_failure, cur_fnc)); - break; - - case ILC_Ret: - /* - * return - set result location and jump out of operation. - */ - gen_ilret(ilc); - cd_add(mk_goto(*scont_strt)); - break; - - case ILC_Susp: - /* - * suspend - set result location. If there is a success - * continuation, call it. Otherwise the "continuation" - * will be generated in-line, so set up a resumption label. - */ - gen_ilret(ilc); - if (cont == NULL) - *scont_strt = cur_fnc->cursor; - lbl1 = oper_lbl("end suspend"); - cd_add(lbl1); - if (cont == NULL) - *scont_fail = lbl1; - else { - cur_fnc->cursor = lbl1->prev; - fail_sav = on_failure; - on_failure = lbl1; - callc_add(cont); - on_failure = fail_sav; - cur_fnc->cursor = lbl1; - } - break; - - case ILC_LBrc: - /* - * non-deletable '{' - */ - cd = NewCode(0); - cd->cd_id = C_LBrack; - cd_add(cd); - break; - - case ILC_RBrc: - /* - * non-deletable '}' - */ - cd = NewCode(0); - cd->cd_id = C_RBrack; - cd_add(cd); - break; - - case ILC_CGto: - /* - * Conditional goto. - */ - i = ilc->n; - if (lbls[i] == NULL) - lbls[i] = oper_lbl("within"); - cd = NewCode(2); - cd->cd_id = C_If; - cd1 = alc_ary(1); - sub_ilc(ilc->code[0], cd1, 0); - cd->Cond = cd1; - cd->ThenStmt = mk_goto(lbls[i]); - cd_add(cd); - break; - - case ILC_Goto: - /* - * Goto. - */ - i = ilc->n; - if (lbls[i] == NULL) - lbls[i] = oper_lbl("within"); - cd_add(mk_goto(lbls[i])); - break; - - case ILC_Lbl: - /* - * Label. - */ - i = ilc->n; - if (lbls[i] == NULL) - lbls[i] = oper_lbl("within"); - cd_add(lbls[i]); - break; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(1); - } - ilc = ilc->next; - } - - if (max_lbl > 0) - free((char *)lbls); - } - -/* - * line_ilc - gather a line of in-line code. - */ -static struct il_c *line_ilc(ilc) -struct il_c *ilc; - { - struct il_c *ilc1; - struct il_c *last; - struct code *cd; - int n; - int i; - - /* - * Count the number of pieces in the line. Determine the last - * piece in the sequence; this is returned to the caller. - */ - n = 0; - ilc1 = ilc; - while (ilc1 != NULL) { - switch(ilc1->il_c_type) { - case ILC_Ref: - case ILC_Mod: - case ILC_Tend: - case ILC_SBuf: - case ILC_CBuf: - case ILC_Str: - ++n; - last = ilc1; - ilc1 = ilc1->next; - break; - default: - ilc1 = NULL; - } - } - - /* - * Construct the line. - */ - cd = alc_ary(n); - for (i = 0; i < n; ++i) { - switch(ilc->il_c_type) { - case ILC_Ref: - case ILC_Mod: - /* - * Reference to variable in symbol table. - */ - cd->ElemTyp(i) = A_ValLoc; - if (ilc->n == RsltIndx) - cd->ValLoc(i) = rslt; - else - cd->ValLoc(i) = cur_symtab[ilc->n].loc; - break; - - case ILC_Tend: - /* - * Reference to a tended variable. - */ - cd->ElemTyp(i) = A_ValLoc; - cd->ValLoc(i) = tended[ilc->n]; - break; - - case ILC_SBuf: - /* - * String buffer for a conversion. - */ - cd->ElemTyp(i) = A_SBuf; - cd->Intgr(i) = alc_sbufs(1, intrnl_lftm); - break; - - case ILC_CBuf: - /* - * Cset buffer for a conversion. - */ - cd->ElemTyp(i) = A_CBuf; - cd->Intgr(i) = alc_cbufs(1, intrnl_lftm); - break; - - case ILC_Str: - /* - * String representing C code. - */ - cd->ElemTyp(i) = A_Str; - cd->Str(i) = ilc->s; - break; - - default: - ilc = NULL; - } - ilc = ilc->next; - } - - cd_add(cd); - return last; - } - -/* - * generate code to perform simple type checking. - */ -struct code *typ_chk(var, typcd) -struct il_code *var; -int typcd; - { - struct code *cd; - - if (typcd == int_typ && largeints) { - /* - * Handle large integer support specially. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(("; - il_var(var, cd, 1); /* value */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ").dword == D_Integer || ("; - il_var(var, cd, 3); /* value */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ").dword == D_Lrgint)"; - return cd; - } - else if (typcd < 0) { - /* - * Not a standard Icon type name. - */ - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - switch (typcd) { - case TypVar: - cd->Str(0) = "((("; - il_var(var, cd, 1); /* value */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ").dword & D_Var) == D_Var)"; - break; - case TypCInt: - cd->Str(0) = "(("; - il_var(var, cd, 1); /* value */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ").dword == D_Integer)"; - break; - } - } - else if (typcd == str_typ) { - cd = alc_ary(3); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(!(("; - il_var(var, cd, 1); /* value */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ").dword & F_Nqual))"; - } - else { - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(("; - il_var(var, cd, 1); /* value */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ").dword == D_"; - cd->ElemTyp(3) = A_Str; - cd->Str(3) = icontypes[typcd].cap_id; /* type name */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ")"; - } - - return cd; - } - -/* - * oper_lbl - generate a label with an associated comment that includes - * the operation name. - */ -static struct code *oper_lbl(s) -char *s; - { - char *sbuf; - - sbuf = (char *)alloc((unsigned int)(strlen(s) + strlen(impl->name) + 3)); - sprintf(sbuf, "%s: %s", s, impl->name); - return alc_lbl(sbuf, 0); - } - -/* - * sav_locs - save the current interpretation of symbols that may - * be affected by conversions. - */ -static struct val_loc **sav_locs() - { - struct val_loc **locs; - int i; - - if (nsyms == 0) - return NULL; - - locs = (struct val_loc **)alloc((unsigned int)(nsyms * - sizeof(struct val_loc *))); - for (i = 0; i < nsyms; ++i) - locs[i] = cur_symtab[i].loc; - return locs; - } - -/* - * rstr_locs - restore the interpretation of symbols that may - * have been affected by conversions. - */ -static void rstr_locs(locs) -struct val_loc **locs; - { - int i; - - for (i = 0; i < nsyms; ++i) - cur_symtab[i].loc = locs[i]; - free((char *)locs); - } - -/* - * mrg_locs - merge the interpretations of symbols along two execution - * paths. Any ambiguity is caught by rtt, so differences only occur - * if one path involves program termination so that the symbols - * no longer have an interpretation along that path. - */ -static void mrg_locs(locs) -struct val_loc **locs; - { - int i; - - for (i = 0; i < nsyms; ++i) - if (cur_symtab[i].loc == NULL) - cur_symtab[i].loc = locs[i]; - free((char *)locs); - } - -/* - * il_cnv - generate code for an in-line conversion. - */ -struct code *il_cnv(typcd, src, dflt, dest) -int typcd; -struct il_code *src; -struct il_c *dflt; -struct il_c *dest; - { - struct code *cd; - struct code *cd1; - int dflt_to_ptr; - int loc; - int is_cstr; - int sym_indx; - int n; - int i; - - sym_indx = src->u[0].n; - - /* - * Determine whether the address must be taken of a default value and - * whether the interpretation of the symbol in an in-place conversion - * changes. - */ - dflt_to_ptr = 0; - loc = PrmTend; - is_cstr = 0; - switch (typcd) { - case TypCInt: - case TypECInt: - loc = PrmInt; - break; - case TypCDbl: - loc = PrmDbl; - break; - case TypCStr: - is_cstr = 1; - break; - case TypEInt: - break; - case TypTStr: - case TypTCset: - dflt_to_ptr = 1; - break; - default: - /* - * Cset, real, integer, or string - */ - if (typcd == cset_typ || typcd == str_typ) - dflt_to_ptr = 1; - break; - } - - if (typcd == TypCDbl && !(eval_is(real_typ, sym_indx) & MaybeFalse)) { - /* - * Conversion from Icon real to C double. Just copy the C value - * from the block. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(GetReal(&("; - il_var(src, cd, 1); - cd->ElemTyp(2) = A_Str; - cd->Str(2) = "), "; - cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, 3); - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "), 1)"; - } - else if (typcd == TypCDbl && !largeints && - !(eval_is(int_typ, sym_indx) & MaybeFalse)) { - /* - * Conversion from Icon integer (not large integer) to C double. - * Do as a C conversion by an assigment. - */ - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "("; - cd->ElemTyp(2) = A_Str; - cd->Str(2) = " = IntVal( "; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "), 1)"; - /* - * Note that cnv_dest() must be called after the source is output - * in case it changes the location of the parameter. - */ - il_var(src, cd, 3); - cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, 1); - } - else { - /* - * Compute the number of code fragments required to construct the - * call to the conversion routine. - */ - n = 7; - if (dflt != NULL) - n += 2; - - cd = alc_ary(n); - - /* - * The names of simple conversions are distinguished from defaulting - * conversions by a prefix of "cnv_" or "def_". - */ - cd->ElemTyp(0) = A_Str; - if (dflt == NULL) - cd->Str(0) = "cnv_"; - else - cd->Str(0) = "def_"; - - /* - * Determine the name of the conversion routine. - */ - cd->ElemTyp(1) = A_Str; /* may be overridden */ - switch (typcd) { - case TypCInt: - cd->Str(1) = "c_int(&("; - break; - case TypCDbl: - cd->Str(1) = "c_dbl(&("; - break; - case TypCStr: - cd->Str(1) = "c_str(&("; - break; - case TypEInt: - cd->Str(1) = "eint(&("; - break; - case TypECInt: - cd->Str(1) = "ec_int(&("; - break; - case TypTStr: - /* - * Allocate a string buffer. - */ - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "tstr("; - cd1->ElemTyp(1) = A_SBuf; - cd1->Intgr(1) = alc_sbufs(1, intrnl_lftm); - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", (&"; - cd->ElemTyp(1) = A_Ary; - cd->Array(1) = cd1; - break; - case TypTCset: - /* - * Allocate a cset buffer. - */ - cd1 = alc_ary(3); - cd1->ElemTyp(0) = A_Str; - cd1->Str(0) = "tcset("; - cd1->ElemTyp(1) = A_CBuf; - cd1->Intgr(1) = alc_cbufs(1, intrnl_lftm); - cd1->ElemTyp(2) = A_Str; - cd1->Str(2) = ", &("; - cd->ElemTyp(1) = A_Ary; - cd->Array(1) = cd1; - break; - default: - /* - * Cset, real, integer, or string - */ - if (typcd == cset_typ) - cd->Str(1) = "cset(&("; - else if (typcd == real_typ) - cd->Str(1) = "real(&("; - else if (typcd == int_typ) - cd->Str(1) = "int(&("; - else if (typcd == str_typ) - cd->Str(1) = "str(&("; - break; - } - - il_var(src, cd, 2); - - cd->ElemTyp(3) = A_Str; - if (dflt != NULL && dflt_to_ptr) - cd->Str(3) = "), &("; - else - cd->Str(3) = "), "; - - - /* - * Determine if this conversion has a default value. - */ - i = 4; - if (dflt != NULL) { - sub_ilc(dflt, cd, i); - ++i; - cd->ElemTyp(i) = A_Str; - if (dflt_to_ptr) - cd->Str(i) = "), "; - else - cd->Str(i) = ", "; - ++i; - } - - cd->ElemTyp(i) = A_Str; - cd->Str(i) = "&("; - ++i; - cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, i); - ++i; - cd->ElemTyp(i) = A_Str; - cd->Str(i) = "))"; - } - return cd; - } - -/* - * il_dflt - generate code for a defaulting conversion that always defaults. - */ -struct code *il_dflt(typcd, src, dflt, dest) -int typcd; -struct il_code *src; -struct il_c *dflt; -struct il_c *dest; - { - struct code *cd; - int sym_indx; - - sym_indx = src->u[0].n; - - if (typcd == TypCDbl) { - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "("; - cnv_dest(PrmDbl, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = " = "; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", 1)"; - } - else if (typcd == TypCInt || typcd == TypECInt) { - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "("; - cnv_dest(PrmInt, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = " = "; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", 1)"; - } - else if (typcd == TypTStr || typcd == str_typ) { - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "("; - cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = " = "; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", 1)"; - } - else if (typcd == TypCStr) { - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(AsgnCStr("; - cnv_dest(0, 1, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ", "; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = "), 1)"; - } - else if (typcd == TypTCset || typcd == cset_typ) { - cd = alc_ary(7); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(BlkLoc("; - cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = (union block *)&"; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", "; - cnv_dest(0, 0, src, sym_indx, dest, cd, 5); /* variable */ - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ".dword = D_Cset, 1)"; - } - else if (typcd == TypEInt || typcd == int_typ) { - cd = alc_ary(7); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "(IntVal("; - cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = "; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", "; - cnv_dest(0, 0, src, sym_indx, dest, cd, 5); /* variable */ - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ".dword = D_Integer, 1)"; - } - else if (typcd == real_typ) { - cd = alc_ary(7); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "((BlkLoc("; - cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ - cd->ElemTyp(2) = A_Str; - cd->Str(2) = ") = (union block *)alcreal("; - sub_ilc(dflt, cd, 3); /* default */ - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ")) == NULL ? (fatalerr(0,NULL), 0) : ("; - cnv_dest(0, 0, src, sym_indx, dest, cd, 5); /* variable */ - cd->ElemTyp(6) = A_Str; - cd->Str(6) = ".dword = D_Real, 1))"; - } - - return cd; - } - -/* - * cnv_dest - output the destination of a conversion. - */ -static void cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, i) -int loc; -int is_cstr; -struct il_code *src; -int sym_indx; -struct il_c *dest; -struct code *cd; -int i; - { - if (dest == NULL) { - /* - * Convert "in place", changing the location of a parameter if needed. - */ - switch (loc) { - case PrmInt: - if (cur_symtab[sym_indx].itmp_indx < 0) - cur_symtab[sym_indx].itmp_indx = alc_itmp(intrnl_lftm); - cur_symtab[sym_indx].loc = itmp_loc(cur_symtab[sym_indx].itmp_indx); - break; - case PrmDbl: - if (cur_symtab[sym_indx].dtmp_indx < 0) - cur_symtab[sym_indx].dtmp_indx = alc_dtmp(intrnl_lftm); - cur_symtab[sym_indx].loc = dtmp_loc(cur_symtab[sym_indx].dtmp_indx); - break; - } - il_var(src, cd, i); - if (is_cstr) - cur_symtab[sym_indx].loc = loc_cpy(cur_symtab[sym_indx].loc,M_CharPtr); - } - else { - if (is_cstr && dest->il_c_type == ILC_Mod && dest->next == NULL && - dest->n != RsltIndx && cur_symtab[dest->n].loc->mod_access != M_None) { - /* - * We are converting to a C string. The destination variable - * is not defined as a simple descriptor, but must be accessed - * as such for this conversion. - */ - cd->ElemTyp(i) = A_ValLoc; - cd->ValLoc(i) = loc_cpy(cur_symtab[dest->n].loc, M_None); - } - else - sub_ilc(dest, cd, i); - } - - } - -/* - * il_copy - produce code for an optimized "conversion" that always succeeds - * and just copies a value from one place to another. - */ -struct code *il_copy(dest, src) -struct il_c *dest; -struct val_loc *src; - { - struct code *cd; - - cd = alc_ary(5); - cd->ElemTyp(0) = A_Str; - cd->Str(0) = "("; - sub_ilc(dest, cd, 1); - cd->ElemTyp(2) = A_Str; - cd->Str(2) = " = "; - cd->ElemTyp(3) = A_ValLoc; - cd->ValLoc(3) = src; - cd->ElemTyp(4) = A_Str; - cd->Str(4) = ", 1)"; - return cd; - } - -/* - * loc_cpy - make a copy of a reference to a value location, but change - * the way the location is accessed. - */ -struct val_loc *loc_cpy(loc, mod_access) -struct val_loc *loc; -int mod_access; - { - struct val_loc *new_loc; - - if (loc == NULL) - return NULL; - new_loc = NewStruct(val_loc); - *new_loc = *loc; - new_loc->mod_access = mod_access; - return new_loc; - } - -/* - * gen_tcase - generate in-line code for a type_case statement. - */ -static int gen_tcase(il, has_dflt) -struct il_code *il; -int has_dflt; - { - struct case_anlz case_anlz; - - /* - * We can only get here if the type_case statement can be implemented - * with a no more than one type check. Determine how simple the - * code can be. - */ - findcases(il, has_dflt, &case_anlz); - if (case_anlz.il_then == NULL) { - if (case_anlz.il_else == NULL) - return 1; - else - return gen_il(case_anlz.il_else); - } - else - return gen_if(typ_chk(il->u[0].fld, case_anlz.typcd), case_anlz.il_then, - case_anlz.il_else, sav_locs()); - } - -/* - * gen_if - generate code to test a condition that might be true - * of false. Determine if execution can continue past this if statement. - */ -static int gen_if(cond_cd, il_then, il_else, locs) -struct code *cond_cd; -struct il_code *il_then; -struct il_code *il_else; -struct val_loc **locs; - { - struct val_loc **locs1; - struct code *lbl_then; - struct code *lbl_end; - struct code *else_loc; - struct code *cd; - int fall_thru; - - lbl_then = oper_lbl("then"); - lbl_end = oper_lbl("end if"); - cd = NewCode(2); - cd->cd_id = C_If; - cd->Cond = cond_cd; - cd->ThenStmt = mk_goto(lbl_then); - cd_add(cd); - else_loc = cur_fnc->cursor; - cd_add(lbl_then); - fall_thru = gen_il(il_then); - cd_add(lbl_end); - locs1 = sav_locs(); - rstr_locs(locs); - cur_fnc->cursor = else_loc; /* go back for the else clause */ - fall_thru |= gen_il(il_else); - cd_add(mk_goto(lbl_end)); - cur_fnc->cursor = lbl_end; - mrg_locs(locs1); - return fall_thru; - } diff --git a/src/iconc/ivalues.c b/src/iconc/ivalues.c deleted file mode 100644 index 4fbb288..0000000 --- a/src/iconc/ivalues.c +++ /dev/null @@ -1,51 +0,0 @@ -/* - * ivalues.c - routines for manipulating Icon values. - */ -#include "../h/gsupport.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ccode.h" -#include "cproto.h" -#include "cglobals.h" - - -/* - * iconint - convert the string representation of an Icon integer to a C long. - * Return -1 if the number is too big and large integers are supported. - */ -long iconint(image) -char *image; - { - register int c; - register int r; - register char *s; - long n, n1; - int overflow; - - s = image; - overflow = 0; - n = 0L; - while ((c = *s++) >= '0' && c <= '9') { - n1 = n * 10 + (c - '0'); - if (n != n1 / 10) - overflow = 1; - n = n1; - } - if (c == 'r' || c == 'R') { - r = n; - n = 0L; - while ((c = *s++) != '\0') { - n1 = n * r + tonum(c); - if (n != n1 / r) - overflow = 1; - n = n1; - } - } - if (overflow) - if (largeints) - n = -1; - else - tfatal("large integer option required", image); - return n; - } diff --git a/src/iconc/lifetime.c b/src/iconc/lifetime.c deleted file mode 100644 index 9a4a7b5..0000000 --- a/src/iconc/lifetime.c +++ /dev/null @@ -1,496 +0,0 @@ -/* - * lifetime.c - perform liveness analysis to determine lifetime of intermediate - * results. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "cglobals.h" -#include "ctree.h" -#include "ctoken.h" -#include "csym.h" -#include "ccode.h" -#include "cproto.h" - -/* - * Prototypes for static functions. - */ -static void arg_life (nodeptr n, long min_result, long max_result, - int resume, int frst_arg, int nargs, nodeptr resumer, - nodeptr *failer, int *gen); - -static int postn = -1; /* relative position in execution order (all neg) */ - -/* - * liveness - compute lifetimes of intermediate results. - */ -void liveness(n, resumer, failer, gen) -nodeptr n; -nodeptr resumer; -nodeptr *failer; -int *gen; - { - struct loop { - nodeptr resumer; - int gen; - nodeptr lifetime; - int every_cntrl; - struct loop *prev; - } loop_info; - struct loop *loop_sav; - static struct loop *cur_loop = NULL; - nodeptr failer1; - nodeptr failer2; - int gen1 = 0; - int gen2 = 0; - struct node *cases; - struct node *clause; - long min_result; /* minimum result sequence length */ - long max_result; /* maximum result sequence length */ - int resume; /* flag - resumption possible after last result */ - - n->postn = postn--; - - switch (n->n_type) { - case N_Activat: - /* - * Activation can fail or succeed. - */ - arg_life(n, 0L, 1L, 0, 1, 2, resumer, failer, gen); - break; - - case N_Alt: - Tree1(n)->lifetime = n->lifetime; - Tree0(n)->lifetime = n->lifetime; - liveness(Tree1(n), resumer, &failer2, &gen2); - liveness(Tree0(n), resumer, &failer1, &gen1); - *failer = failer2; - *gen = 1; - break; - - case N_Apply: - /* - * Assume operation can suspend or fail. - */ - arg_life(n, 0L, UnbndSeq, 1, 0, 2, resumer, failer, gen); - break; - - case N_Augop: - /* - * Impl0(n) is assignment. Impl1(n) is the augmented operation. - */ - min_result = Impl0(n)->min_result * Impl1(n)->min_result; - max_result = Impl0(n)->max_result * Impl1(n)->max_result; - resume = Impl0(n)->resume | Impl1(n)->resume; - arg_life(n, min_result, max_result, resume, 2, 2, resumer, failer, - gen); - break; - - case N_Bar: - if (resumer == NULL) - n->intrnl_lftm = n; - else - n->intrnl_lftm = resumer; - Tree0(n)->lifetime = n->lifetime; - liveness(Tree0(n), resumer, failer, &gen1); - *gen = 1; - break; - - case N_Break: - if (cur_loop == NULL) { - nfatal(n, "invalid context for break", NULL); - return; - } - Tree0(n)->lifetime = cur_loop->lifetime; - loop_sav = cur_loop; - cur_loop = cur_loop->prev; - liveness(Tree0(n), loop_sav->resumer, &failer1, &gen1); - cur_loop = loop_sav; - cur_loop->gen |= gen1; - *failer = NULL; - *gen = 0; - break; - - case N_Case: - *failer = resumer; - *gen = 0; - - cases = Tree1(n); - while (cases != NULL) { - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - /* - * Body. - */ - Tree1(clause)->lifetime = n->lifetime; - liveness(Tree1(clause), resumer, &failer2, &gen2); - if (resumer == NULL && failer2 != NULL) - *failer = n; - *gen |= gen2; - - /* - * The expression being compared can be resumed. - */ - Tree0(clause)->lifetime = clause; - liveness(Tree0(clause), clause, &failer1, &gen1); - } - - if (Tree2(n) == NULL) { - if (resumer == NULL) - *failer = n; - } - else { - Tree2(n)->lifetime = n->lifetime; - liveness(Tree2(n), resumer, &failer2, &gen2); /* default */ - if (resumer == NULL && failer2 != NULL) - *failer = n; - *gen |= gen2; - } - - /* - * control clause is bounded - */ - Tree0(n)->lifetime = n; - liveness(Tree0(n), NULL, &failer1, &gen1); - if (failer1 != NULL && *failer == NULL) - *failer = failer1; - break; - - case N_Create: - Tree0(n)->lifetime = n; - loop_sav = cur_loop; - cur_loop = NULL; /* check for invalid break and next */ - liveness(Tree0(n), n, &failer1, &gen1); - cur_loop = loop_sav; - *failer = NULL; - *gen = 0; - break; - - case N_Cset: - case N_Empty: - case N_Id: - case N_Int: - case N_Real: - case N_Str: - *failer = resumer; - *gen = 0; - break; - - case N_Field: - Tree0(n)->lifetime = n; - liveness(Tree0(n), resumer, failer, gen); - break; - - case N_If: - Tree1(n)->lifetime = n->lifetime; - liveness(Tree1(n), resumer, failer, gen); - if (Tree2(n)->n_type != N_Empty) { - Tree2(n)->lifetime = n->lifetime; - liveness(Tree2(n), resumer, &failer2, &gen2); - if (failer2 != NULL) { - if (*failer == NULL) - *failer = failer2; - else { - if ((*failer)->postn < failer2->postn) - *failer = failer2; - if ((*failer)->postn < n->postn) - *failer = n; - } - } - *gen |= gen2; - } - /* - * control clause is bounded - */ - Tree0(n)->lifetime = NULL; - liveness(Tree0(n), NULL, &failer1, &gen1); - if (Tree2(n)->n_type == N_Empty && failer1 != NULL && *failer == NULL) - *failer = failer1; - break; - - case N_Invok: - /* - * Assume operation can suspend and fail. - */ - arg_life(n, 0L, UnbndSeq, 1, 1, Val0(n) + 1, resumer, failer, gen); - break; - - case N_InvOp: - arg_life(n, Impl1(n)->min_result, Impl1(n)->max_result, - Impl1(n)->resume, 2, Val0(n), resumer, failer, gen); - break; - - case N_InvProc: - if (Proc1(n)->ret_flag & DoesFail) - min_result = 0L; - else - min_result = 1L; - if (Proc1(n)->ret_flag & DoesSusp) { - max_result = UnbndSeq; - resume = 1; - } - else { - max_result = 1L; - resume = 0; - } - arg_life(n, min_result, max_result, resume, 2, Val0(n), resumer, - failer, gen); - break; - - case N_InvRec: - arg_life(n, err_conv ? 0L : 1L, 1L, 1, 2, Val0(n), resumer, failer, - gen); - break; - - case N_Limit: - if (resumer == NULL) - n->intrnl_lftm = n; - else - n->intrnl_lftm = resumer; - Tree0(n)->lifetime = n->lifetime; - liveness(Tree0(n), resumer, &failer1, &gen1); - Tree1(n)->lifetime = n; - liveness(Tree1(n), failer1 == NULL ? n : failer1, &failer2, &gen2); - *failer = failer2; - *gen = gen1 | gen2; - break; - - case N_Loop: { - loop_info.prev = cur_loop; - loop_info.resumer = resumer; - loop_info.gen = 0; - loop_info.every_cntrl = 0; - loop_info.lifetime = n->lifetime; - cur_loop = &loop_info; - switch ((int)Val0(Tree0(n))) { - case EVERY: - /* - * The body is bounded. The control clause is resumed - * by the control structure. - */ - Tree2(n)->lifetime = NULL; - liveness(Tree2(n), NULL, &failer2, &gen2); - loop_info.every_cntrl = 1; - Tree1(n)->lifetime = NULL; - liveness(Tree1(n), n, &failer1, &gen1); - break; - - case REPEAT: - /* - * The body is bounded. - */ - Tree1(n)->lifetime = NULL; - liveness(Tree1(n), NULL, &failer1, &gen1); - break; - - case SUSPEND: - /* - * The body is bounded. The control clause is resumed - * by the control structure. - */ - Tree2(n)->lifetime = NULL; - liveness(Tree2(n), NULL, &failer2, &gen2); - loop_info.every_cntrl = 1; - Tree1(n)->lifetime = n; - liveness(Tree1(n), n, &failer1, &gen1); - break; - - case WHILE: - case UNTIL: - /* - * The body and the control clause are each bounded. - */ - Tree2(n)->lifetime = NULL; - liveness(Tree2(n), NULL, &failer1, &gen1); - Tree1(n)->lifetime = NULL; - liveness(Tree1(n), NULL, &failer1, &gen1); - break; - } - *failer = (resumer == NULL ? n : resumer); /* assume a loop can fail */ - *gen = cur_loop->gen; - cur_loop = cur_loop->prev; - } - break; - - case N_Next: - if (cur_loop == NULL) { - nfatal(n, "invalid context for next", NULL); - return; - } - if (cur_loop->every_cntrl) - *failer = n; - else - *failer = NULL; - *gen = 0; - break; - - case N_Not: - /* - * The expression is bounded. - */ - Tree0(n)->lifetime = NULL; - liveness(Tree0(n), NULL, &failer1, &gen1); - *failer = (resumer == NULL ? n : resumer); - *gen = 0; - break; - - case N_Ret: - if (Val0(Tree0(n)) == RETURN) { - /* - * The expression is bounded. - */ - Tree1(n)->lifetime = n; - liveness(Tree1(n), NULL, &failer1, &gen1); - } - *failer = NULL; - *gen = 0; - break; - - case N_Scan: { - struct implement *asgn_impl; - - if (resumer == NULL) - n->intrnl_lftm = n; - else - n->intrnl_lftm = resumer; - - if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) { - asgn_impl = optab[asgn_loc].binary; - arg_life(n, asgn_impl->min_result, asgn_impl->max_result, - asgn_impl->resume, 1, 2, resumer, failer, gen); - } - else { - Tree2(n)->lifetime = n->lifetime; - liveness(Tree2(n), resumer, &failer2, &gen2); /* body */ - Tree1(n)->lifetime = n; - liveness(Tree1(n), failer2, &failer1, &gen1); /* subject */ - *failer = failer1; - *gen = gen1 | gen2; - } - } - break; - - case N_Sect: - /* - * Impl0(n) is sectioning. - */ - min_result = Impl0(n)->min_result; - max_result = Impl0(n)->max_result; - resume = Impl0(n)->resume; - if (Impl1(n) != NULL) { - /* - * Impl1(n) is plus or minus. - */ - min_result *= Impl1(n)->min_result; - max_result *= Impl1(n)->max_result; - resume |= Impl1(n)->resume; - } - arg_life(n, min_result, max_result, resume, 2, 3, resumer, failer, - gen); - break; - - case N_Slist: - /* - * expr1 is not bounded, expr0 is bounded. - */ - Tree1(n)->lifetime = n->lifetime; - liveness(Tree1(n), resumer, failer, gen); - Tree0(n)->lifetime = NULL; - liveness(Tree0(n), NULL, &failer1, &gen1); - break; - - case N_SmplAsgn: - Tree3(n)->lifetime = n; - liveness(Tree3(n), resumer, failer, gen); /* 2nd operand */ - Tree2(n)->lifetime = n->lifetime; /* may be result of := */ - liveness(Tree2(n), *failer, &failer1, &gen1); /* 1st operand */ - break; - - case N_SmplAug: - /* - * Impl1(n) is the augmented operation. - */ - arg_life(n, Impl1(n)->min_result, Impl1(n)->max_result, - Impl1(n)->resume, 2, 2, resumer, failer, gen); - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - } - -/* - * arg_life - compute the lifetimes of an argument list. - */ -static void arg_life(n, min_result, max_result, resume, frst_arg, nargs, - resumer, failer, gen) -nodeptr n; -long min_result; /* minimum result sequence length */ -long max_result; /* maximum result sequence length */ -int resume; /* flag - resumption possible after last result */ -int frst_arg; -int nargs; -nodeptr resumer; -nodeptr *failer; -int *gen; - { - nodeptr failer1; - nodeptr failer2; - nodeptr lifetime; - int inv_fail; /* failure after operation in invoked */ - int reuse; - int gen2; - int i; - - /* - * Determine what, if anything, can resume the rightmost argument. - */ - if (resumer == NULL && min_result == 0) - failer1 = n; - else - failer1 = resumer; - if (failer1 == NULL) - inv_fail = 0; - else - inv_fail = 1; - - /* - * If the operation can be resumed, variables internal to the operation - * have and extended lifetime. - */ - if (resumer != NULL && (max_result > 1 || max_result == UnbndSeq || resume)) - n->intrnl_lftm = resumer; - else - n->intrnl_lftm = n; - - /* - * Go through the parameter list right to left, propagating resumption - * information, computing lifetimes, and determining whether anything - * can generate. - */ - lifetime = n; - reuse = 0; - *gen = 0; - for (i = frst_arg + nargs - 1; i >= frst_arg; --i) { - n->n_field[i].n_ptr->lifetime = lifetime; - n->n_field[i].n_ptr->reuse = reuse; - liveness(n->n_field[i].n_ptr, failer1, &failer2, &gen2); - if (resumer != NULL && gen2) - lifetime = resumer; - if (inv_fail && gen2) - reuse = 1; - failer1 = failer2; - *gen |= gen2; - } - *failer = failer1; - if (max_result > 1 || max_result == UnbndSeq) - *gen = 1; - } diff --git a/src/iconc/types.c b/src/iconc/types.c deleted file mode 100644 index cd3a3ef..0000000 --- a/src/iconc/types.c +++ /dev/null @@ -1,893 +0,0 @@ -/* - * typinfer.c - routines to perform type inference. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ctoken.h" -#include "cglobals.h" -#include "ccode.h" -#include "cproto.h" -#ifdef TypTrc -#ifdef HighResTime -#include <sys/time.h> -#include <sys/resource.h> -#endif /* HighResTime */ -#endif /* TypTrc */ - -extern unsigned int null_bit; /* bit for null type */ -extern unsigned int str_bit; /* bit for string type */ -extern unsigned int cset_bit; /* bit for cset type */ -extern unsigned int int_bit; /* bit for integer type */ -extern unsigned int real_bit; /* bit for real type */ -extern unsigned int n_icntyp; /* number of non-variable types */ -extern unsigned int n_intrtyp; /* number of types in intermediate values */ -extern unsigned int val_mask; /* mask for non-var types in last int of type*/ -extern struct typ_info *type_array; - -/* - * free_struct_typinfo - frees a struct typinfo structure by placing - * it one a list of free structures - */ -#ifdef OptimizeType -extern struct typinfo *start_typinfo; -extern struct typinfo *high_typinfo; -extern struct typinfo *low_typinfo; -extern struct typinfo *free_typinfo; - -void free_struct_typinfo(struct typinfo *typ) { - - typ->bits = (unsigned int *)free_typinfo; - free_typinfo = typ; -} -#endif /* OptimizeType */ - -/* - * alloc_typ - allocate a compressed type structure and initializes - * the members to zero or NULL. - */ -#ifdef OptimizeType -struct typinfo *alloc_typ(n_types) -#else /* OptimizeType */ -unsigned int *alloc_typ(n_types) -#endif /* OptimizeType */ -int n_types; -{ -#ifdef OptimizeType - struct typinfo *typ; - int i; - unsigned int init = 0; - - if ((free_typinfo == NULL) && (high_typinfo == low_typinfo)) { - /* - * allocate a large block of memory used to parcel out struct typinfo - * structures from - */ - start_typinfo = (struct typinfo *)alloc(sizeof(struct typinfo) * TYPINFO_BLOCK); - high_typinfo = start_typinfo; - low_typinfo = start_typinfo + TYPINFO_BLOCK; - free_typinfo = NULL; - typ = start_typinfo; - high_typinfo++; - } - else if (free_typinfo != NULL) { - /* - * get a typinfo stucture from the list of free structures - */ - typ = free_typinfo; - free_typinfo = (struct typinfo *)free_typinfo->bits; - } - else { - /* - * get a typinfo structure from the chunk of memory allocated - * previously - */ - typ = high_typinfo; - high_typinfo++; - } - typ->packed = n_types; - if (!do_typinfer) - typ->bits = alloc_mem_typ(n_types); - else - typ->bits= NULL; - return typ; -#else /* OptimizeType */ - int n_ints; - unsigned int *typ; - int i; - unsigned int init = 0; - - n_ints = NumInts(n_types); - typ = (unsigned int *)alloc((unsigned int)((n_ints)*sizeof(unsigned int))); - - /* - * Initialization: if we are doing inference, start out assuming no types. - * If we are not doing inference, assume any type. - */ - if (!do_typinfer) - init = ~init; - for (i = 0; i < n_ints; ++i) - typ[i] = init; - return typ; -#endif /* OptimizeType */ -} - -/* - * alloc_mem_typ - actually allocates a full sized bit vector. - */ -#ifdef OptimizeType -unsigned int *alloc_mem_typ(n_types) -unsigned int n_types; -{ - int n_ints; - unsigned int *typ; - int i; - unsigned int init = 0; - - n_ints = NumInts(n_types); - typ = (unsigned int *)alloc((unsigned int)((n_ints)*sizeof(unsigned int))); - if (!do_typinfer) - init = ~init; - for(i=0; i < n_ints ;++i) - typ[i] = init; - return typ; -} -#endif /* OptimizeType */ - -/* - * set_typ - set a particular type bit in a type bit vector. - */ -void set_typ(type, bit) -#ifdef OptimizeType -struct typinfo *type; -#else /* OptimizeType */ -unsigned int *type; -#endif /* OptimizeType */ -unsigned int bit; -{ - unsigned int indx; - unsigned int mask; - -#ifdef OptimizeType - if (type->bits == NULL) { - if (bit == null_bit) - type->packed |= NULL_T; - else if (bit == real_bit) - type->packed |= REAL_T; - else if (bit == int_bit) - type->packed |= INT_T; - else if (bit == cset_bit) - type->packed |= CSET_T; - else if (bit == str_bit) - type->packed |= STR_T; - else { - /* - * if the bit to set is not one of the five builtin types - * then allocate a whole bit vector, copy the packed - * bits over, and set the requested bit - */ - type->bits = alloc_mem_typ(DecodeSize(type->packed)); - xfer_packed_types(type); - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - type->bits[indx] |= mask; - } - } - else { - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - type->bits[indx] |= mask; - } -#else /* OptimizeType */ - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - type[indx] |= mask; -#endif /* OptimizeType */ -} - -/* - * clr_type - clear a particular type bit in a type bit vector. - */ -void clr_typ(type, bit) -#ifdef OptimizeType -struct typinfo *type; -#else /* OptimizeType */ -unsigned int *type; -#endif /* OptimizeType */ -unsigned int bit; -{ - unsigned int indx; - unsigned int mask; - -#ifdef OptimizeType - if (type->bits == NULL) { - /* - * can only clear one of five builtin types - */ - if (bit == null_bit) - type->packed &= ~NULL_T; - else if (bit == real_bit) - type->packed &= ~REAL_T; - else if (bit == int_bit) - type->packed &= ~INT_T; - else if (bit == cset_bit) - type->packed &= ~CSET_T; - else if (bit == str_bit) - type->packed &= ~STR_T; - } - else { - /* - * build bit mask to clear requested type in full bit vector - */ - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - type->bits[indx] &= ~mask; - } -#else /* OptimizeType */ - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - type[indx] &= ~mask; -#endif /* OptimizeType */ -} - -/* - * has_type - determine if a bit vector representing types has any bits - * set that correspond to a specific type code from the data base. Also, - * if requested, clear any such bits. - */ -int has_type(typ, typcd, clear) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -int typcd; -int clear; -{ - int frst_bit, last_bit; - int i; - int found; - - found = 0; - bitrange(typcd, &frst_bit, &last_bit); - for (i = frst_bit; i < last_bit; ++i) { - if (bitset(typ, i)) { - found = 1; - if (clear) - clr_typ(typ, i); - } - } - return found; -} - -/* - * other_type - determine if a bit vector representing types has any bits - * set that correspond to a type *other* than specific type code from the - * data base. - */ -int other_type(typ, typcd) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -int typcd; - { - int frst_bit, last_bit; - int i; - - bitrange(typcd, &frst_bit, &last_bit); - for (i = 0; i < frst_bit; ++i) - if (bitset(typ, i)) - return 1; - for (i = last_bit; i < n_intrtyp; ++i) - if (bitset(typ, i)) - return 1; - return 0; - } - -/* - * bitrange - determine the range of bit positions in a type bit vector - * that correspond to a type code from the data base. - */ -void bitrange(typcd, frst_bit, last_bit) -int typcd; -int *frst_bit; -int *last_bit; - { - if (typcd == TypVar) { - /* - * All variable types. - */ - *frst_bit = n_icntyp; - *last_bit = n_intrtyp; - } - else { - *frst_bit = type_array[typcd].frst_bit; - *last_bit = *frst_bit + type_array[typcd].num_bits; - } - } - -/* - * typcd_bits - set the bits of a bit vector corresponding to a type - * code from the data base. - */ -void typcd_bits(typcd, typ) -int typcd; -struct type *typ; - { - int frst_bit; - int last_bit; - int i; - - if (typcd == TypEmpty) - return; /* Do nothing. */ - - if (typcd == TypAny) { - /* - * Set bits corresponding to first-class types. - */ -#ifdef OptimizeType - /* - * allocate a full bit vector and copy over packed types first - */ - if (typ->bits->bits == NULL) { - typ->bits->bits = alloc_mem_typ(DecodeSize(typ->bits->packed)); - xfer_packed_types(typ->bits); - } - for (i = 0; i < NumInts(n_icntyp) - 1; ++i) - typ->bits->bits[i] |= ~(unsigned int)0; - typ->bits->bits[i] |= val_mask; -#else /* OptimizeType */ - for (i = 0; i < NumInts(n_icntyp) - 1; ++i) - typ->bits[i] |= ~(unsigned int)0; - typ->bits[i] |= val_mask; -#endif /* OptimizeType */ - return; - } - - bitrange(typcd, &frst_bit, &last_bit); -#ifdef OptimizeType - if (last_bit > DecodeSize(typ->bits->packed)) /* bad abstract type computation */ - return; -#endif /* OptimizeType */ - for (i = frst_bit; i < last_bit; ++i) - set_typ(typ->bits, i); - } - -/* - * bitset - determine if a specific bit in a bit vector is set. - */ -int bitset(typ, bit) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -int bit; -{ - int mask; - int indx; - -#ifdef OptimizeType - if (typ->bits == NULL) { - /* - * check to see if the requested bit is set in the packed representation - * if the requested bit is not one of the five builtins then the - * lookup fails no matter what - */ - if (bit == null_bit) - return (typ->packed & NULL_T); - else if (bit == real_bit) - return (typ->packed & REAL_T); - else if (bit == int_bit) - return (typ->packed & INT_T); - else if (bit == cset_bit) - return (typ->packed & CSET_T); - else if (bit == str_bit) - return (typ->packed & STR_T); - else - return 0; - } - else { - /* - * create a mask to check to see if the requested type bit is - * set on - */ - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - return typ->bits[indx] & mask; - } -#else /* OptimizeType */ - indx = bit / IntBits; - mask = 1; - mask <<= bit % IntBits; - return typ[indx] & mask; -#endif /* OptimizeType */ -} - -/* - * is_empty - determine if a type bit vector is empty. - */ -int is_empty(typ) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -{ - int i; - -#ifdef OptimizeType - if (typ->bits == NULL) { - /* - * if any bits are set on then the vector is not empty - */ - if (DecodePacked(typ->packed)) - return 0; - else - return 1; - } - else { - for (i = 0; i < NumInts(n_intrtyp); ++i) { - if (typ->bits[i] != 0) - return 0; - } - return 1; - } -#else /* OptimizeType */ - for (i = 0; i < NumInts(n_intrtyp); ++i) { - if (typ[i] != 0) - return 0; - } - return 1; -#endif /* OptimizeType */ -} - -/* - * xfer_packed_types - transfers the packed type representation - * to a full length bit vector representation in the same - * struct typinfo structure. - */ -#ifdef OptimizeType -void xfer_packed_types(type) -struct typinfo *type; -{ - unsigned int indx, mask; - - /* - * for each IF statement built a mask to set each of the five builtins - * if they are present in the packed representation - */ - if (type->packed & NULL_T) { - indx = null_bit / IntBits; - mask = 1; - mask <<= null_bit % IntBits; - type->bits[indx] |= mask; - } - if (type->packed & REAL_T) { - indx = real_bit / IntBits; - mask = 1; - mask <<= real_bit % IntBits; - type->bits[indx] |= mask; - } - if (type->packed & INT_T) { - indx = int_bit / IntBits; - mask = 1; - mask <<= int_bit % IntBits; - type->bits[indx] |= mask; - } - if (type->packed & CSET_T) { - indx = cset_bit / IntBits; - mask = 1; - mask <<= cset_bit % IntBits; - type->bits[indx] |= mask; - } - if (type->packed & STR_T) { - indx = str_bit / IntBits; - mask = 1; - mask <<= str_bit % IntBits; - type->bits[indx] |= mask; - } -} - -/* - * xfer_packed_to_bits - sets those type bits from the src typinfo structure - * to the dest typinfo structure AND the src is a packed representation - * while the dest is a bit vector. Returns the number of new bits that - * were set in the destination. - */ -int xfer_packed_to_bits(src, dest, nsize) -struct typinfo *src; -struct typinfo *dest; -int nsize; -{ - unsigned int indx, mask, old, rnsize; - int changes[5] = {-1,-1,-1,-1,-1}; - int ix, membr = 0, i; - - ix = 0; - rnsize = NumInts(nsize); - /* - * for each possible type set in the packed vector, create a mask - * and apply it to the dest. check to see if there was actually - * a change in the dest vector. - */ - if (src->packed & NULL_T) { - indx = null_bit / IntBits; - if (indx < rnsize) { - mask = 1; - mask <<= null_bit % IntBits; - old = dest->bits[indx]; - dest->bits[indx] |= mask; - if (old != dest->bits[indx]) { - membr = 0; - for (i=0; i < 5 ;i++) - /* - * checks to see if the bit just set happens to be in the - * same word as any other of the five builtins. if they - * are then we only want to count this as one change - */ - if (indx == changes[i]) { - membr = 1; break; - } - if (!membr) - changes[ix++] = indx; - } - } - } - if (src->packed & REAL_T) { - indx = real_bit / IntBits; - if (indx < rnsize) { - mask = 1; - mask <<= real_bit % IntBits; - old = dest->bits[indx]; - dest->bits[indx] |= mask; - if (old != dest->bits[indx]) { - membr = 0; - for (i=0; i < 5 ;i++) - if (indx == changes[i]) { - membr = 1; break; - } - if (!membr) - changes[ix++] = indx; - } - } - } - if (src->packed & INT_T) { - indx = int_bit / IntBits; - if (indx < rnsize) { - mask = 1; - mask <<= int_bit % IntBits; - old = dest->bits[indx]; - dest->bits[indx] |= mask; - if (old != dest->bits[indx]) { - membr = 0; - for (i=0; i < 5 ;i++) - if (indx == changes[i]) { - membr = 1; break; - } - if (!membr) - changes[ix++] = indx; - } - } - } - if (src->packed & CSET_T) { - indx = cset_bit / IntBits; - if (indx < rnsize) { - mask = 1; - mask <<= cset_bit % IntBits; - old = dest->bits[indx]; - dest->bits[indx] |= mask; - if (old != dest->bits[indx]) { - membr = 0; - for (i=0; i < 5 ;i++) - if (indx == changes[i]) { - membr = 1; break; - } - if (!membr) - changes[ix++] = indx; - } - } - } - if (src->packed & STR_T) { - indx = str_bit / IntBits; - if (indx < rnsize) { - mask = 1; - mask <<= str_bit % IntBits; - old = dest->bits[indx]; - dest->bits[indx] |= mask; - if (old != dest->bits[indx]) { - membr = 0; - for (i=0; i < 5 ;i++) - if (indx == changes[i]) { - membr = 1; break; - } - if (!membr) - changes[ix++] = indx; - } - } - } - return ix; -} - -/* - * and_bits_to_packed - performs a bitwise AND of two typinfo structures - * taking into account of packed or full bit representation. - */ -void and_bits_to_packed(src, dest, size) -struct typinfo *src; -struct typinfo *dest; -int size; -{ - unsigned int indx, mask, val, destsz; - int i; - - if ((src->bits == NULL) && (dest->bits == NULL)) - /* Both are packed */ - dest->packed &= (0xFF000000 | src->packed); - else if ((src->bits == NULL) && (dest->bits != NULL)) { - /* - * built a bit mask for each type in the src and AND it too - * the bit vector in dest - */ - for (i=0; i < NumInts(size) ;i++) { - val = get_bit_vector(src,i); - dest->bits[i] &= val; - } - } - else if ((src->bits != NULL) && (dest->bits == NULL)) { - /* - * because an AND is being performed only those bits in the dest - * have the possibility of remaining set (i.e. five builtins) - * therefore if the bit is set in the packed check to see if - * it is also set in the full vector, if so then set it in the - * resulting vector, otherwise don't - */ - destsz = DecodeSize(dest->packed); - mask = 1; val = 0; - if (dest->packed & NULL_T) { - mask <<= (null_bit % IntBits); - if (src->bits[(null_bit/IntBits)] & mask) - val |= NULL_T; - } - mask = 1; - if (dest->packed & REAL_T) { - mask <<= (real_bit % IntBits); - if (src->bits[(real_bit/IntBits)] & mask) - val |= REAL_T; - } - mask = 1; - if (dest->packed & INT_T) { - mask <<= (int_bit % IntBits); - if (src->bits[(int_bit/IntBits)] & mask) - val |= INT_T; - } - mask = 1; - if (dest->packed & CSET_T) { - mask <<= (cset_bit % IntBits); - if (src->bits[(cset_bit/IntBits)] & mask) - val |= CSET_T; - } - mask = 1; - if (dest->packed & STR_T) { - mask <<= (str_bit % IntBits); - if (src->bits[(str_bit/IntBits)] & mask) - val |= STR_T; - } - dest->packed = val | destsz; - } - else - for (i=0; i < NumInts(size) ;i++) - dest->bits[i] &= src->bits[i]; -} - - -/* - * get_bit_vector - returns a bit mask from the selected word of a bit - * vector. e.g. if pos == 2, then check to see if any of the five - * builtins fall in the second word of a normal bit vector, if so - * create a bit mask with those types that fall in that word. - */ - -unsigned int get_bit_vector(src, pos) -struct typinfo *src; -int pos; -{ - unsigned int val = 0, mask; - - val = 0; - if ((src->packed & NULL_T) && ((null_bit / IntBits) == pos)) { - mask = 1; - mask <<= null_bit % IntBits; - val |= mask; - } - if ((src->packed & REAL_T) && ((real_bit / IntBits) == pos)) { - mask = 1; - mask <<= real_bit % IntBits; - val |= mask; - } - if ((src->packed & INT_T) && ((int_bit / IntBits) == pos)) { - mask = 1; - mask <<= int_bit % IntBits; - val |= mask; - } - if ((src->packed & CSET_T) && ((cset_bit / IntBits) == pos)) { - mask = 1; - mask <<= cset_bit % IntBits; - val |= mask; - } - if ((src->packed & STR_T) && ((str_bit / IntBits) == pos)) { - mask = 1; - mask <<= str_bit % IntBits; - val |= mask; - } - return val; -} - - -/* - * clr_packed - clears all bits within the nsize-th word for a packed - * representation. - */ - -void clr_packed(src, nsize) -struct typinfo *src; -int nsize; -{ - unsigned int rnsize; - - rnsize = NumInts(nsize); - if ((null_bit / IntBits) < rnsize) - src->packed &= ~NULL_T; - if ((real_bit / IntBits) < rnsize) - src->packed &= ~REAL_T; - if ((int_bit / IntBits) < rnsize) - src->packed &= ~INT_T; - if ((cset_bit / IntBits) < rnsize) - src->packed &= ~CSET_T; - if ((str_bit / IntBits) < rnsize) - src->packed &= ~STR_T; -} - -/* - * cpy_packed_to_packed - copies the packed bits from one bit vector - * to another. - */ - -void cpy_packed_to_packed(src, dest, nsize) -struct typinfo *src; -struct typinfo *dest; -int nsize; -{ - unsigned int indx, rnsize; - - rnsize = NumInts(nsize); - /* - * for each of the possible builtin types, check to see if the bit is - * set in the src and if present set it in the dest. - */ - dest->packed = DecodeSize(dest->packed); - if (src->packed & NULL_T) { - indx = null_bit / IntBits; - if (indx < rnsize) - dest->packed |= NULL_T; - } - if (src->packed & REAL_T) { - indx = real_bit / IntBits; - if (indx < rnsize) - dest->packed |= REAL_T; - } - if (src->packed & INT_T) { - indx = int_bit / IntBits; - if (indx < rnsize) - dest->packed |= INT_T; - } - if (src->packed & CSET_T) { - indx = cset_bit / IntBits; - if (indx < rnsize) - dest->packed |= CSET_T; - } - if (src->packed & STR_T) { - indx = str_bit / IntBits; - if (indx < rnsize) - dest->packed |= STR_T; - } -} - - -/* - * mrg_packed_to_packed - merges the packed type bits of a src and dest - * bit vector. - */ -int mrg_packed_to_packed(src, dest, nsize) -struct typinfo *src; -struct typinfo *dest; -int nsize; -{ - unsigned int indx, rnsize; - int changes[5] = {-1,-1,-1,-1,-1}; - int ix = 0, membr = 0, i; - - rnsize = NumInts(nsize); - /* - * for each of the five possible types in the src, check to see if it - * is set in the src and not set in the dest. if so then set it in - * the dest vector. - */ - if ((src->packed & NULL_T) && !(dest->packed & NULL_T)) { - indx = null_bit / IntBits; - if (indx < rnsize) { - dest->packed |= NULL_T; - for(i=0; i<5 ;i++) { - if (indx == changes[i]) { - membr = 1; break; - } - } - if (!membr) - changes[ix++] = indx; - } - } - if ((src->packed & REAL_T) && !(dest->packed & REAL_T)) { - indx = real_bit / IntBits; - if (indx < rnsize) { - dest->packed |= REAL_T; - for(i=0; i<5 ;i++) { - if (indx == changes[i]) { - membr = 1; break; - } - } - if (!membr) - changes[ix++] = indx; - } - } - if ((src->packed & INT_T) && !(dest->packed & INT_T)){ - indx = int_bit / IntBits; - if (indx < rnsize) { - dest->packed |= INT_T; - for(i=0; i<5 ;i++) { - if (indx == changes[i]) { - membr = 1; break; - } - } - if (!membr) - changes[ix++] = indx; - } - } - if ((src->packed & CSET_T) && !(dest->packed & CSET_T)) { - indx = cset_bit / IntBits; - if (indx < rnsize) { - dest->packed |= CSET_T; - for(i=0; i<5 ;i++) { - if (indx == changes[i]) { - membr = 1; break; - } - } - if (!membr) - changes[ix++] = indx; - } - } - if ((src->packed & STR_T) && !(dest->packed & STR_T)) { - indx = str_bit / IntBits; - if (indx < rnsize) { - dest->packed |= STR_T; - for(i=0; i<5 ;i++) { - if (indx == changes[i]) { - membr = 1; break; - } - } - if (!membr) - changes[ix++] = indx; - } - } - return ix; -} -#endif /* OptimizeType */ diff --git a/src/iconc/typinfer.c b/src/iconc/typinfer.c deleted file mode 100644 index 8a96e23..0000000 --- a/src/iconc/typinfer.c +++ /dev/null @@ -1,5189 +0,0 @@ -/* - * typinfer.c - routines to perform type inference. - */ -#include "../h/gsupport.h" -#include "../h/lexdef.h" -#include "ctrans.h" -#include "csym.h" -#include "ctree.h" -#include "ctoken.h" -#include "cglobals.h" -#include "ccode.h" -#include "cproto.h" -#ifdef TypTrc -#ifdef HighResTime -#include <sys/time.h> -#include <sys/resource.h> -#endif /* HighResTime */ -#endif /* TypTrc */ - -/* - * Information about co-expressions is keep on a list. - */ -struct t_coexpr { - nodeptr n; /* code for co-expression */ - int typ_indx; /* relative type number (index) */ - struct store *in_store; /* store entry into co-expression via activation */ - struct store *out_store; /* store at end of co-expression */ -#ifdef OptimizeType - struct typinfo *act_typ; /* types passed via co-expression activation */ - struct typinfo *rslt_typ; /* types resulting from "co-expression return" */ -#else /* OptimizeType */ - unsigned int *act_typ; /* types passed via co-expression activation */ - unsigned int *rslt_typ; /* types resulting from "co-expression return" */ -#endif /* OptimizeType */ - int iteration; - struct t_coexpr *next; - }; - -struct t_coexpr *coexp_lst; - -#ifdef TypTrc -extern int typealloc; /* flag to account for allocation */ -extern long typespace; /* amount of space for type inference */ -#endif /* TypTrc */ - -struct symtyps *cur_symtyps; /* maps run-time routine symbols to types */ - -/* - * argtyps is the an array of types large enough to accommodate the argument - * list of any operation. - */ -struct argtyps { - struct argtyps *next; -#ifdef OptimizeType - struct typinfo *types[1]; /* actual size is max_prm */ -#else /* OptimizeType */ - unsigned int *types[1]; /* actual size is max_prm */ -#endif /* OptimizeType */ - }; - -/* - * prototypes for static functions. - */ -#ifdef OptimizeType -void and_bits_to_packed (struct typinfo *src, - struct typinfo *dest, int size); -struct typinfo *alloc_typ (int n_types); -unsigned int *alloc_mem_typ (unsigned int n_types); -int bitset (struct typinfo *typ, int bit); -void clr_typ (struct typinfo *type, unsigned int bit); -void clr_packed (struct typinfo *src, int nsize); -void cpy_packed_to_packed (struct typinfo *src, - struct typinfo *dest, int nsize); -static void deref_lcl (struct typinfo *src, - struct typinfo *dest); -static int findloops ( struct node *n, int resume, - struct typinfo *rslt_type); -static void gen_inv (struct typinfo *prc_typ, nodeptr n); -int has_type (struct typinfo *typ, int typcd, int clear); -static void infer_impl (struct implement *impl, - nodeptr n, struct symtyps *symtyps, - struct typinfo *rslt_typ); -int is_empty (struct typinfo *typ); -int mrg_packed_to_packed (struct typinfo *src, - struct typinfo *dest, int nsize); -int other_type (struct typinfo *typ, int typcd); -static void set_ret (struct typinfo *typ); -void set_typ (struct typinfo *type, unsigned int bit); -void typcd_bits (int typcd, struct type *typ); -static void typ_deref (struct typinfo *src, - struct typinfo *dest, int chk); -int xfer_packed_to_bits (struct typinfo *src, - struct typinfo *dest, int nsize); -#else /* OptimizeType */ -unsigned int *alloc_typ (int n_types); -int bitset (unsigned int *typ, int bit); -void clr_typ (unsigned int *type, unsigned int bit); -static void deref_lcl (unsigned int *src, unsigned int *dest); -static int findloops ( struct node *n, int resume, - unsigned int *rslt_type); -static void gen_inv (unsigned int *prc_typ, nodeptr n); -int has_type (unsigned int *typ, int typcd, int clear); -static void infer_impl (struct implement *impl, - nodeptr n, struct symtyps *symtyps, - unsigned int *rslt_typ); -int is_empty (unsigned int *typ); -int other_type (unsigned int *typ, int typcd); -static void set_ret (unsigned int *typ); -void set_typ (unsigned int *type, unsigned int bit); -void typcd_bits (int typcd, struct type *typ); -static void typ_deref (unsigned int *src, unsigned int *dest, int chk); -#endif /* OptimizeType */ - -static void abstr_new (struct node *n, struct il_code *il); -static void abstr_typ (struct il_code *il, struct type *typ); -static struct store *alloc_stor (int stor_sz, int n_types); -static void chk_succ (int ret_flag, struct store *susp_stor); -static struct store *cpy_store (struct store *source); -static int eval_cond (struct il_code *il); -static void free_argtyp (struct argtyps *argtyps); -static void free_store (struct store *store); -static void free_wktyp (struct type *typ); -static void find_new (struct node *n); -static struct argtyps *get_argtyp (void); -static struct store *get_store (int clear); -static struct type *get_wktyp (void); -static void infer_act (nodeptr n); -static void infer_con (struct rentry *rec, nodeptr n); -static int infer_il (struct il_code *il); -static void infer_nd (nodeptr n); -static void infer_prc (struct pentry *proc, nodeptr n); -static void mrg_act (struct t_coexpr *coexp, - struct store *e_store, - struct type *rslt_typ); -static void mrg_store (struct store *source, struct store *dest); -static void side_effect (struct il_code *il); -static struct symtyps *symtyps (int nsyms); - -#ifdef TypTrc -static void prt_d_typ (FILE *file, struct typinfo *typ); -static void prt_typ (FILE *file, struct typinfo *typ); -#endif /* TypTrc */ - -#define CanFail 1 - -/* - * cur_coexp is non-null while performing type inference on code from a - * create expression. If it is null, the possible current co-expressions - * must be found from cur_proc. - */ -struct t_coexpr *cur_coexp = NULL; - -struct gentry **proc_map; /* map procedure types to symbol table entries */ -struct rentry **rec_map; /* map record types to record information */ -struct t_coexpr **coexp_map; /* map co-expression types to information */ - -struct typ_info *type_array; - -static int num_new; /* number of types supporting "new" abstract type comp */ - -/* - * Data base component codes are mapped to type inferencing information - * using an array. - */ -struct compnt_info { - int frst_bit; /* first bit in bit vector allocated to component */ - int num_bits; /* number of bits allocated to this component */ - struct store *store; /* maps component "reference" to the type it holds */ - }; -static struct compnt_info *compnt_array; - -static unsigned int frst_fld; /* bit number of 1st record field */ -static unsigned int n_fld; /* number of record fields */ -static unsigned int frst_gbl; /* bit number of 1st global reference type */ -static unsigned int n_gbl; /* number of global variables */ -static unsigned int n_nmgbl; /* number of named global variables */ -static unsigned int frst_loc; /* bit number of 1st local reference type */ -static unsigned int n_loc; /* maximum number of locals in any procedure */ - -static unsigned int nxt_bit; /* next unassigned bit in bit vector */ -unsigned int n_icntyp; /* number of non-variable types */ -unsigned int n_intrtyp; /* number of types in intermediate values */ -static unsigned int n_rttyp; /* number of types in runtime computations */ -unsigned int val_mask; /* mask for non-var types in last int of type */ - -unsigned int null_bit; /* bit for null type */ -unsigned int str_bit; /* bit for string type */ -unsigned int cset_bit; /* bit for cset type */ -unsigned int int_bit; /* bit for integer type */ -unsigned int real_bit; /* bit for real type */ - -static struct store *fld_stor; /* record fields */ - -static int *cur_new; /* allocated types for current operation */ - -static struct store *succ_store = NULL; /* current success store */ -static struct store *fail_store = NULL; /* current failure store */ - -static struct store *dummy_stor; -static struct store *store_pool = NULL; /* free list of store structs */ - -static struct type *type_pool = NULL; /* free list of type structs */ -static struct type cur_rslt = {0, NULL, NULL}; /* result type of operation */ - -static struct argtyps *argtyp_pool = NULL; /* free list of arg type arrays */ -static struct argtyps *arg_typs = NULL; /* current arg type array */ - -static int num_args; /* number of arguments for current operation */ -static int n_vararg; /* size of variable part of arg list to run-time routine */ - -#ifdef OptimizeType -static struct typinfo *any_typ; /* type bit vector with all bits on */ -struct typinfo *free_typinfo = NULL; -struct typinfo *start_typinfo = NULL; -struct typinfo *high_typinfo = NULL; -struct typinfo *low_typinfo = NULL; -#else /* OptimizeType */ -static unsigned int *any_typ; /* type bit vector with all bits on */ -#endif /* OptimizeType */ - -long changed; /* number of changes to type information in this iteration */ -int iteration; /* iteration number for type inferencing */ - -#ifdef TypTrc -static FILE *trcfile = NULL; /* output file pointer for tracing */ -static char *trcname = NULL; /* output file name for tracing */ -static char *trc_indent = ""; -#endif /* TypTrc */ - - -/* - * typeinfer - infer types of operands. If "do_typinfer" is set, actually - * do abstract interpretation, otherwise assume any type for all operands. - */ -void typeinfer() - { - struct gentry *gptr; - struct lentry *lptr; - nodeptr call_main; - struct pentry *p; - struct rentry *rec; - struct t_coexpr *coexp; - struct store *init_store; - struct store *f_store; -#ifdef OptimizeType - struct typinfo *type; -#else /* OptimizeType */ - unsigned int *type; -#endif /* OptimizeType */ - struct implement *ip; - struct lentry **lhash; - struct lentry **vartypmap; - int i, j, k; - int size; - int flag; - -#ifdef TypTrc - /* - * Set up for type tracing. - */ - long start_infer, end_infer; - -#ifdef HighResTime - struct rusage rusage; - - getrusage(RUSAGE_SELF, &rusage); - start_infer = rusage.ru_utime.tv_sec*1000 + rusage.ru_utime.tv_usec/1000; -#else /* HighResTime */ - start_infer = millisec(); -#endif /* HighResTime */ - - typealloc = 1; /* note allocation in this phase */ - - trcname = getenv("TYPTRC"); - - if (trcname != NULL && strlen(trcname) != 0) { - - if (trcname[0] == '|') { - FILE *popen(); - - trcfile = popen(trcname+1, "w"); - } - else - - trcfile = fopen(trcname, "w"); - - if (trcfile == NULL) { - fprintf(stderr, "TYPTRC: cannot open %s\n", trcname); - fflush(stderr); - exit(EXIT_FAILURE); - } - } -#endif /* TypTrc */ - - /* - * Make sure max_prm is large enough for any run-time routine. - */ - for (i = 0; i < IHSize; ++i) - for (ip = bhash[i]; ip != NULL; ip = ip->blink) - if (ip->nargs > max_prm) - max_prm = ip->nargs; - for (i = 0; i < IHSize; ++i) - for (ip = ohash[i]; ip != NULL; ip = ip->blink) - if (ip->nargs > max_prm) - max_prm = ip->nargs; - - /* - * Allocate an arrays to map data base type codes and component codes - * to type inferencing information. - */ - type_array = (struct typ_info *)alloc((unsigned int)(num_typs * - sizeof(struct typ_info))); - compnt_array = (struct compnt_info *)alloc((unsigned int)(num_cmpnts * - sizeof(struct compnt_info))); - - /* - * Find those types that support the "new" abstract type computation - * assign to them locations in the arrays of allocated types associated - * with operation invocations. Also initialize the number of type bits. - * Types with no subtypes have one bit. Types allocated with the the "new" - * abstract have a default sub-type that is allocated here. Procedures - * have a subtype to for string invocable operators. Co-expressions - * have a subtype for &main. Records are handled below. - */ - num_new = 0; - for (i = 0; i < num_typs; ++i) { - if (icontypes[i].support_new) - type_array[i].new_indx = num_new++; - type_array[i].num_bits = 1; /* reserve one type bit */ - } - type_array[list_typ].num_bits = 2; /* default & list for arg to main() */ - - cur_coexp = NewStruct(t_coexpr); - cur_coexp->n = NULL; - cur_coexp->next = NULL; - coexp_lst = cur_coexp; - - if (do_typinfer) { - /* - * Go through the syntax tree for each procedure locating program - * points that may create structures at run time. Allocate the - * appropriate structure type(s) to each such point. - */ - for (p = proc_lst; p != NULL; p = p->next) { - if (p->nargs < 0) - p->arg_lst = type_array[list_typ].num_bits++; /* list for varargs */ - find_new(Tree1(p->tree)); /* initial clause */ - find_new(Tree2(p->tree)); /* body of procedure */ - } - } - - /* - * Allocate a type number for each record type (use record number for - * offset) and a variable type number for each field. - */ - n_fld = 0; - if (rec_lst == NULL) { - type_array[rec_typ].num_bits = 0; - rec_map = NULL; - } - else { - type_array[rec_typ].num_bits = rec_lst->rec_num + 1; - rec_map = (struct rentry **)alloc( - (unsigned int)((rec_lst->rec_num + 1)*sizeof(struct rentry *))); - for (rec = rec_lst; rec != NULL; rec = rec->next) { - rec->frst_fld = n_fld; - n_fld += rec->nfields; - rec_map[rec->rec_num] = rec; - } - } - - /* - * Allocate type numbers to global variables. Don't count those procedure - * variables that are no longer referenced in the syntax tree. Do count - * static variables. Also allocate types to procedures, built-in functions, - * record constructors. - */ - n_gbl = 0; - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { - flag = gptr->flag; - if (flag & F_SmplInv) - gptr->index = -1; /* unused: set to something not a valid type */ - else { - gptr->index = n_gbl++; - if (flag & (F_Proc | F_Record | F_Builtin)) - gptr->init_type = type_array[proc_typ].num_bits++; - } - if (flag & F_Proc) { - for (lptr = gptr->val.proc->statics; lptr != NULL;lptr = lptr->next) - lptr->val.index = n_gbl++; - } - } - n_nmgbl = n_gbl; - - /* - * Determine relative bit numbers for predefined variable types that - * are treated as sets of global variables. - */ - for (i = 0; i < num_typs; ++i) - if (icontypes[i].deref == DrfGlbl) - type_array[i].frst_bit = n_gbl++; /* converted to absolute later */ - - proc_map = (struct gentry **)alloc( - (unsigned int)((type_array[proc_typ].num_bits)*sizeof(struct gentry *))); - proc_map[0] = NULL; /* proc type for string invocable operators */ - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { - flag = gptr->flag; - if (!(flag & F_SmplInv) && (flag & (F_Proc | F_Record | F_Builtin))) - proc_map[gptr->init_type] = gptr; - } - - /* - * Allocate type numbers to local variables. The same numbers are reused - * in different procedures. - */ - n_loc = 0; - for (p = proc_lst; p != NULL; p = p->next) { - i = Abs(p->nargs); - for (lptr = p->args; lptr != NULL; lptr = lptr->next) - lptr->val.index = --i; - i = Abs(p->nargs); - for (lptr = p->dynams; lptr != NULL; lptr = lptr->next) - lptr->val.index = i++; - n_loc = Max(n_loc, i); - - /* - * produce a mapping from the variable types used in this procedure - * to the corresponding symbol table entries. - */ - if (n_gbl + n_loc == 0) - vartypmap = NULL; - else - vartypmap = (struct lentry **)alloc( - (unsigned int)((n_gbl + n_loc)*sizeof(struct lentry *))); - for (i = 0; i < n_gbl + n_loc; ++i) - vartypmap[i] = NULL; /* no entries for foreign statics */ - p->vartypmap = vartypmap; - lhash = p->lhash; - for (i = 0; i < LHSize; ++i) { - for (lptr = lhash[i]; lptr != NULL; lptr = lptr->blink) { - switch (lptr->flag) { - case F_Global: - gptr = lptr->val.global; - if (!(gptr->flag & F_SmplInv)) - vartypmap[gptr->index] = lptr; - break; - case F_Static: - vartypmap[lptr->val.index] = lptr; - break; - case F_Dynamic: - case F_Argument: - vartypmap[n_gbl + lptr->val.index] = lptr; - } - } - } - } - - /* - * There is a component reference subtype for every subtype of the - * associated aggregate type. - */ - for (i = 0; i < num_cmpnts; ++i) - compnt_array[i].num_bits = type_array[typecompnt[i].aggregate].num_bits; - - /* - * Assign bits for non-variable (first-class) types. - */ - nxt_bit = 0; - for (i = 0; i < num_typs; ++i) - if (icontypes[i].deref == DrfNone) { - type_array[i].frst_bit = nxt_bit; - nxt_bit += type_array[i].num_bits; - } - - n_icntyp = nxt_bit; /* number of first-class types */ - - /* - * Load some commonly needed bit numbers into global variable. - */ - null_bit = type_array[null_typ].frst_bit; - str_bit = type_array[str_typ].frst_bit; - cset_bit = type_array[cset_typ].frst_bit; - int_bit = type_array[int_typ].frst_bit; - real_bit = type_array[real_typ].frst_bit; - - /* - * Assign bits for predefined variable types that are not treated as - * sets of globals. - */ - for (i = 0; i < num_typs; ++i) - if (icontypes[i].deref == DrfCnst || icontypes[i].deref == DrfSpcl) { - type_array[i].frst_bit = nxt_bit; - nxt_bit += type_array[i].num_bits; - } - - /* - * Assign bits to aggregate compontents that are variables. - */ - for (i = 0; i < num_cmpnts; ++i) - if (typecompnt[i].var) { - compnt_array[i].frst_bit = nxt_bit; - nxt_bit += compnt_array[i].num_bits; - } - - /* - * Assign bits to record fields and named variables. - */ - frst_fld = nxt_bit; - nxt_bit += n_fld; - frst_gbl = nxt_bit; - nxt_bit += n_gbl; - frst_loc = nxt_bit; - nxt_bit += n_loc; - - /* - * Convert from relative to ablsolute bit numbers for predefined variable - * types that are treated as sets of global variables. - */ - for (i = 0; i < num_typs; ++i) - if (icontypes[i].deref == DrfGlbl) - type_array[i].frst_bit += frst_gbl; - - n_intrtyp = nxt_bit; /* number of types for intermediate values */ - - /* - * Assign bits to aggregate compontents that are not variables. These - * are the runtime system's internal descriptor reference types. - */ - for (i = 0; i < num_cmpnts; ++i) - if (!typecompnt[i].var) { - compnt_array[i].frst_bit = nxt_bit; - nxt_bit += compnt_array[i].num_bits; - } - - n_rttyp = nxt_bit; /* total size of type system */ - -#ifdef TypTrc - if (trcfile != NULL) { - /* - * Output a summary of the type system. - */ - for (i = 0; i < num_typs; ++i) { - fprintf(trcfile, "%s", icontypes[i].id); - if (strcmp(icontypes[i].id, icontypes[i].abrv) != 0) - fprintf(trcfile, "(%s)", icontypes[i].abrv); - fprintf(trcfile, " sub-types: %d\n", type_array[i].num_bits); - } - } -#endif /* TypTrc */ - - /* - * The division between bits for first-class types and variables types - * generally occurs in the middle of a word. Set up a mask for extracting - * the first-class types from this word. - */ - val_mask = 0; - i = n_icntyp - (NumInts(n_icntyp) - 1) * IntBits; - while (i--) - val_mask = (val_mask << 1) | 1; - - if (do_typinfer) { - /* - * Create stores large enough for the component references. These - * are global to the entire program, rather than being propagated - * from node to node in the syntax tree. - */ - for (i = 0; i < num_cmpnts; ++i) { - if (i == str_var) - size = n_intrtyp; - else - size = n_icntyp; - compnt_array[i].store = alloc_stor(compnt_array[i].num_bits, size); - } - fld_stor = alloc_stor(n_fld, n_icntyp); - - dummy_stor = get_store(0); - - /* - * First list is arg to main: a list of strings. - */ - set_typ(compnt_array[lst_elem].store->types[1], str_typ); - } - - /* - * Set up a type bit vector with all bits on. - */ -#ifdef OptimizeType - any_typ = alloc_typ(n_rttyp); - any_typ->bits = alloc_mem_typ(DecodeSize(any_typ->packed)); - for (i = 0; i < NumInts(n_rttyp); ++i) - any_typ->bits[i] = ~(unsigned int)0; -#else /* OptimizeType */ - any_typ = alloc_typ(n_rttyp); - for (i = 0; i < NumInts(n_rttyp); ++i) - any_typ[i] = ~(unsigned int)0; -#endif /* OptimizeType */ - - /* - * Initialize stores and return values for procedures. Also initialize - * flag indicating whether the procedure can be executed. - */ - call_main = NULL; - for (p = proc_lst; p != NULL; p = p->next) { - if (do_typinfer) { - p->iteration = 0; - p->ret_typ = alloc_typ(n_intrtyp); - p->coexprs = alloc_typ(n_icntyp); - p->in_store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (p->ret_flag & DoesSusp) - p->susp_store = alloc_stor(n_gbl, n_icntyp); - else - p->susp_store = NULL; - for (i = Abs(p->nargs); i < n_loc; ++i) - set_typ(p->in_store->types[n_gbl + i], null_bit); - if (p->nargs < 0) - set_typ(p->in_store->types[n_gbl + Abs(p->nargs) - 1], - type_array[list_typ].frst_bit + p->arg_lst); - if (strcmp(p->name, "main") == 0) { - /* - * create a the initial call to main with one list argument. - */ - call_main = invk_main(p); - call_main->type = alloc_typ(n_intrtyp); - Tree2(call_main)->type = alloc_typ(n_intrtyp); - set_typ(Tree2(call_main)->type, type_array[list_typ].frst_bit + 1); - call_main->store = alloc_stor(n_gbl + n_loc, n_icntyp); - } - p->out_store = alloc_stor(n_gbl, n_icntyp); - p->reachable = 0; - } - else - p->reachable = 1; - /* - * Analyze the code of the procedure to determine where to place stores - * that survive iterations of type inferencing. Note, both the initial - * clause and the body of the procedure are bounded. - */ - findloops(Tree1(p->tree), 0, NULL); - findloops(Tree2(p->tree), 0, NULL); - } - - /* - * If type inferencing is suppressed, we have set up very conservative - * type information and will do no inferencing. - */ - if (!do_typinfer) - return; - - if (call_main == NULL) - return; /* no main procedure, cannot continue */ - if (tfatals > 0) - return; /* don't do inference if there are fatal errors */ - - /* - * Construct mapping from co-expression types to information - * about the co-expressions and finish initializing the information. - */ - i = type_array[coexp_typ].num_bits; - coexp_map = (struct t_coexpr **)alloc( - (unsigned int)(i * sizeof(struct t_coexpr *))); - for (coexp = coexp_lst; coexp != NULL; coexp = coexp->next) { - coexp_map[--i] = coexp; - coexp->typ_indx = i; - coexp->in_store = alloc_stor(n_gbl + n_loc, n_icntyp); - coexp->out_store = alloc_stor(n_gbl + n_loc, n_icntyp); - coexp->act_typ = alloc_typ(n_intrtyp); - coexp->rslt_typ = alloc_typ(n_intrtyp); - coexp->iteration = 0; - } - - /* - * initialize globals - */ - init_store = get_store(1); - for (i = 0; i < GHSize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { - flag = gptr->flag; - if (!(flag & F_SmplInv)) { - type = init_store->types[gptr->index]; - if (flag & (F_Proc | F_Record | F_Builtin)) - set_typ(type, type_array[proc_typ].frst_bit + gptr->init_type); - else - set_typ(type, null_bit); - } - } - - /* - * Initialize types for predefined variable types. - */ - for (i = 0; i < num_typs; ++i) { - type = NULL; - switch (icontypes[i].deref) { - case DrfGlbl: - /* - * Treated as a global variable. - */ - type = init_store->types[type_array[i].frst_bit - frst_gbl]; - break; - case DrfCnst: - /* - * Type doesn't change so keep one copy. - */ - type = alloc_typ(n_intrtyp); - type_array[i].typ = type; - break; - } - if (type != NULL) { - /* - * Determine which types are in the initial type for this variable. - */ - for (j = 0; j < num_typs; ++j) { - if (icontypes[i].typ[j] != '.') { - for (k = 0; k < type_array[j].num_bits; ++k) - set_typ(type, type_array[j].frst_bit + k); - } - } - } - } - - f_store = get_store(1); - - /* - * Type inferencing iterates over the program until a fixed point is - * reached. - */ - changed = 1L; /* force first iteration */ - iteration = 0; - if (verbose > 1) - fprintf(stderr, "type inferencing: "); - - while (changed > 0L) { - changed = 0L; - ++iteration; - -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, "**** iteration %d ****\n", iteration); -#endif /* TypTrc */ - - /* - * Start at the implicit initial call to the main procedure. Inferencing - * walks the call graph from here. - */ - succ_store = cpy_store(init_store); - fail_store = f_store; - infer_nd(call_main); - - /* - * If requested, monitor the progress of inferencing. - */ - switch (verbose) { - case 0: - case 1: - break; - case 2: - fprintf(stderr, "."); - break; - default: /* > 2 */ - if (iteration != 1) - fprintf(stderr, ", "); - fprintf(stderr, "%ld", changed); - } - } - - /* - * Type inferencing is finished, complete any diagnostic output. - */ - if (verbose > 1) - fprintf(stderr, "\n"); - -#ifdef TypTrc - if (trcfile != NULL) { - -#ifdef HighResTime - getrusage(RUSAGE_SELF, &rusage); - end_infer = rusage.ru_utime.tv_sec*1000 + rusage.ru_utime.tv_usec/1000; -#else /* HighResTime */ - end_infer = millisec(); -#endif /* HighResTime */ - fprintf(trcfile, "\n**** inferencing time: %ld milliseconds\n", - end_infer - start_infer); - fprintf(trcfile, "\n**** inferencing space: %ld bytes\n",typespace); - fclose(trcfile); - } - typealloc = 0; -#endif /* TypTrc */ - } - -/* - * find_new - walk the syntax tree allocating structure types where - * operations create new structures. - */ -static void find_new(n) -struct node *n; - { - struct t_coexpr *coexp; - struct node *cases; - struct node *clause; - int nargs; - int i; - - n->new_types = NULL; - switch (n->n_type) { - case N_Cset: - case N_Empty: - case N_Id: - case N_Int: - case N_Next: - case N_Real: - case N_Str: - break; - - case N_Bar: - case N_Break: - case N_Field: - case N_Not: - find_new(Tree0(n)); - break; - - case N_Alt: - case N_Apply: - case N_Limit: - case N_Slist: - find_new(Tree0(n)); - find_new(Tree1(n)); - break; - - case N_Activat: - find_new(Tree1(n)); - find_new(Tree2(n)); - break; - - case N_If: - find_new(Tree0(n)); /* control clause */ - find_new(Tree1(n)); /* then clause */ - find_new(Tree2(n)); /* else clause, may be N_Empty */ - break; - - case N_Create: - /* - * Allocate a sub-type for the co-expressions created here. - */ - n->new_types = (int *)alloc((unsigned int)(sizeof(int))); - n->new_types[0] = type_array[coexp_typ].num_bits++; - coexp = NewStruct(t_coexpr); - coexp->n = Tree0(n); - coexp->next = coexp_lst; - coexp_lst = coexp; - find_new(Tree0(n)); - break; - - case N_Augop: - abstr_new(n, Impl0(n)->in_line); /* assignment */ - abstr_new(n, Impl1(n)->in_line); /* the operation */ - find_new(Tree2(n)); /* 1st operand */ - find_new(Tree3(n)); /* 2nd operand */ - break; - - case N_Case: - find_new(Tree0(n)); /* control clause */ - cases = Tree1(n); - while (cases != NULL) { - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - find_new(Tree0(clause)); /* value of clause */ - find_new(Tree1(clause)); /* body of clause */ - } - if (Tree2(n) != NULL) - find_new(Tree2(n)); /* deflt */ - break; - - case N_Invok: - nargs = Val0(n); /* number of arguments */ - find_new(Tree1(n)); /* thing being invoked */ - for (i = 1; i <= nargs; ++i) - find_new(n->n_field[i+1].n_ptr); /* arg i */ - break; - - case N_InvOp: - /* - * This is a call to an operation, this is what we must - * check for "new" abstract type computation. - */ - nargs = Val0(n); /* number of arguments */ - abstr_new(n, Impl1(n)->in_line); /* operation */ - for (i = 1; i <= nargs; ++i) - find_new(n->n_field[i+1].n_ptr); /* arg i */ - break; - - case N_InvProc: - case N_InvRec: - nargs = Val0(n); /* number of arguments */ - for (i = 1; i <= nargs; ++i) - find_new(n->n_field[i+1].n_ptr); /* arg i */ - break; - - case N_Loop: - switch ((int)Val0(Tree0(n))) { - case EVERY: - case SUSPEND: - case WHILE: - case UNTIL: - find_new(Tree1(n)); /* control clause */ - find_new(Tree2(n)); /* do clause - may be N_Empty*/ - break; - - case REPEAT: - find_new(Tree1(n)); /* clause */ - break; - } - - case N_Ret: - if (Val0(Tree0(n)) == RETURN) - find_new(Tree1(n)); /* value - may be N_Empty */ - break; - - case N_Scan: - if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) - abstr_new(n, optab[asgn_loc].binary->in_line); - find_new(Tree1(n)); /* subject */ - find_new(Tree2(n)); /* body */ - break; - - case N_Sect: - abstr_new(n, Impl0(n)->in_line); /* sectioning */ - if (Impl1(n) != NULL) - abstr_new(n, Impl1(n)->in_line); /* plus, minus, or nothing */ - find_new(Tree2(n)); /* 1st operand */ - find_new(Tree3(n)); /* 2nd operand */ - find_new(Tree4(n)); /* 3rd operand */ - break; - - case N_SmplAsgn: - case N_SmplAug: - find_new(Tree3(n)); - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - } - -/* - * abstr_new - find the abstract clauses in the implementation of an operation. - * If they indicate that the operations creates structures, allocate a - * type for the structures and associate it with the node in the syntax tree. - */ -static void abstr_new(n, il) -struct node *n; -struct il_code *il; - { - int i; - int num_cases, indx; - struct typ_info *t_info; - - if (il == NULL) - return; - - switch (il->il_type) { - case IL_New: - /* - * We have found a "new" construct in an abstract type computation. - * Make sure an array has been created to hold the types allocated - * to this call, then allocate the indicated type if one has not - * already been allocated. - */ - if (n->new_types == NULL) { - n->new_types = (int *)alloc((unsigned int)(num_new * sizeof(int))); - for (i = 0; i < num_new; ++i) - n->new_types[i] = -1; - } - t_info = &type_array[il->u[0].n]; /* index by type code */ - if (n->new_types[t_info->new_indx] < 0) { - n->new_types[t_info->new_indx] = t_info->num_bits++; -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, "%s (%d,%d) %s\n", n->n_file, n->n_line, - n->n_col, icontypes[il->u[0].n].id); -#endif /* TypTrc */ - } - i = il->u[1].n; /* num args */ - indx = 2; - while (i--) - abstr_new(n, il->u[indx++].fld); - break; - - case IL_If1: - abstr_new(n, il->u[1].fld); - break; - - case IL_If2: - abstr_new(n, il->u[1].fld); - abstr_new(n, il->u[2].fld); - break; - - case IL_Tcase1: - num_cases = il->u[1].n; - indx = 2; - for (i = 0; i < num_cases; ++i) { - indx += 2; /* skip type info */ - abstr_new(n, il->u[indx++].fld); /* action */ - } - break; - - case IL_Tcase2: - num_cases = il->u[1].n; - indx = 2; - for (i = 0; i < num_cases; ++i) { - indx += 2; /* skip type info */ - abstr_new(n, il->u[indx++].fld); /* action */ - } - abstr_new(n, il->u[indx].fld); /* default */ - break; - - case IL_Lcase: - num_cases = il->u[0].n; - indx = 1; - for (i = 0; i < num_cases; ++i) { - ++indx; /* skip selection num */ - abstr_new(n, il->u[indx++].fld); /* action */ - } - abstr_new(n, il->u[indx].fld); /* default */ - break; - - case IL_Acase: - abstr_new(n, il->u[2].fld); /* C_integer action */ - if (largeints) - abstr_new(n, il->u[3].fld); /* integer action */ - abstr_new(n, il->u[4].fld); /* C_double action */ - break; - - case IL_Abstr: - case IL_Inter: - case IL_Lst: - case IL_TpAsgn: - case IL_Union: - abstr_new(n, il->u[0].fld); - abstr_new(n, il->u[1].fld); - break; - - case IL_Compnt: - case IL_Store: - case IL_VarTyp: - abstr_new(n, il->u[0].fld); - break; - - case IL_Block: - case IL_Call: - case IL_Const: /* should have been replaced by literal node */ - case IL_Err1: - case IL_Err2: - case IL_IcnTyp: - case IL_Subscr: - case IL_Var: - break; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(EXIT_FAILURE); - } - } - -/* - * alloc_stor - allocate a store with empty types. - */ -static struct store *alloc_stor(stor_sz, n_types) -int stor_sz; -int n_types; - { - struct store *stor; - int i; - - /* - * If type inferencing is disabled, we don't actually make use of - * any stores, but the initialization code asks for them anyway. - */ - if (!do_typinfer) - return NULL; - -#ifdef OptimizeType - stor = (struct store *)alloc((unsigned int)(sizeof(struct store) + - ((stor_sz - 1) * sizeof(struct typinfo *)))); - stor->next = NULL; - stor->perm = 1; - for (i = 0; i < stor_sz; ++i) { - stor->types[i] = (struct typinfo *)alloc_typ(n_types); - } -#else /* OptimizeType */ - stor = (struct store *)alloc((unsigned int)(sizeof(struct store) + - ((stor_sz - 1) * sizeof(unsigned int *)))); - stor->next = NULL; - stor->perm = 1; - for (i = 0; i < stor_sz; ++i) { - stor->types[i] = (unsigned int *)alloc_typ(n_types); - } -#endif /* OptimizeType */ - - return stor; - } - -/* - * findloops - find both explicit loops and implicit loops caused by - * goal-directed evaluation. Allocate stores for them. Determine which - * expressions cannot fail (used to eliminate dynamic store allocation - * for some bounded expressions). Allocate stores for 'if' and 'case' - * expressions that can be resumed. Initialize expression types. - * The syntax tree is walked in reverse execution order looking for - * failure and for generators. - */ -static int findloops(n, resume, rslt_type) -struct node *n; -int resume; -#ifdef OptimizeType -struct typinfo *rslt_type; -#else /* OptimizeType */ -unsigned int *rslt_type; -#endif /* OptimizeType */ - { - struct loop { - int resume; - int can_fail; - int every_cntrl; -#ifdef OptimizeType - struct typinfo *type; -#else /* OptimizeType */ - unsigned int *type; -#endif /* OptimizeType */ - struct loop *prev; - } loop_info; - struct loop *loop_sav; - static struct loop *cur_loop = NULL; - struct node *cases; - struct node *clause; - int can_fail; - int nargs, i; - - n->store = NULL; - if (!do_typinfer) - rslt_type = any_typ; - - switch (n->n_type) { - case N_Activat: - if (rslt_type == NULL) - rslt_type = alloc_typ(n_intrtyp); - n->type = rslt_type; - /* - * Assume activation can fail. - */ - can_fail = findloops(Tree2(n), 1, NULL); - can_fail = findloops(Tree1(n), can_fail, NULL); - n->symtyps = symtyps(2); - if (optab[Val0(Tree0(n))].tok.t_type == AUGAT) - n->symtyps->next = symtyps(2); - break; - - case N_Alt: - if (rslt_type == NULL) - rslt_type = alloc_typ(n_intrtyp); - n->type = rslt_type; - -#ifdef TypTrc - rslt_type = NULL; /* don't share result loc with subexpressions*/ -#endif /* TypTrc */ - - if (resume) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - can_fail = findloops(Tree0(n), resume, rslt_type) | - findloops(Tree1(n), resume, rslt_type); - break; - - case N_Apply: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - /* - * Assume operation can suspend or fail. - */ - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - can_fail = findloops(Tree1(n), 1, NULL); - can_fail = findloops(Tree0(n), can_fail, NULL); - n->symtyps = symtyps(max_sym); - break; - - case N_Augop: - if (rslt_type == NULL) - rslt_type = alloc_typ(n_intrtyp); - n->type = rslt_type; - - can_fail = resume; - /* - * Impl0(n) is assignment. - */ - if (resume && Impl0(n)->ret_flag & DoesSusp) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (MightFail(Impl0(n)->ret_flag)) - can_fail = 1; - /* - * Impl1(n) is the augmented operation. - */ - if (can_fail && Impl1(n)->ret_flag & DoesSusp && n->store == NULL) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (MightFail(Impl1(n)->ret_flag)) - can_fail = 1; - can_fail = findloops(Tree3(n), can_fail, NULL); /* operand 2 */ - can_fail = findloops(Tree2(n), can_fail, NULL); /* operand 1 */ - n->type = Tree2(n)->type; - Typ4(n) = alloc_typ(n_intrtyp); - n->symtyps = symtyps(n_arg_sym(Impl1(n))); - n->symtyps->next = symtyps(n_arg_sym(Impl0(n))); - break; - - case N_Bar: - can_fail = findloops(Tree0(n), resume, rslt_type); - n->type = Tree0(n)->type; - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - break; - - case N_Break: - if (cur_loop == NULL) { - nfatal(n, "invalid context for break", NULL); - return 0; - } - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - loop_sav = cur_loop; - cur_loop = cur_loop->prev; - loop_sav->can_fail |= findloops(Tree0(n), loop_sav->resume, - loop_sav->type); - cur_loop = loop_sav; - can_fail = 0; - break; - - case N_Case: - if (rslt_type == NULL) - rslt_type = alloc_typ(n_intrtyp); - n->type = rslt_type; - -#ifdef TypTrc - rslt_type = NULL; /* don't share result loc with subexpressions*/ -#endif /* TypTrc */ - - if (resume) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - - /* - * control clause is bounded - */ - can_fail = findloops(Tree0(n), 0, NULL); - - cases = Tree1(n); - while (cases != NULL) { - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - /* - * The expression being compared can be resumed. - */ - findloops(Tree0(clause), 1, NULL); - - /* - * Body. - */ - can_fail |= findloops(Tree1(clause), resume, rslt_type); - } - - if (Tree2(n) == NULL) - can_fail = 1; - else - can_fail |= findloops(Tree2(n), resume, rslt_type); /* default */ - break; - - case N_Create: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - findloops(Tree0(n), 1, NULL); /* co-expression code */ - /* - * precompute type - */ - i= type_array[coexp_typ].frst_bit; - if (do_typinfer) - i += n->new_types[0]; - set_typ(n->type, i); - can_fail = resume; - break; - - case N_Cset: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - set_typ(n->type, type_array[cset_typ].frst_bit); /* precompute type */ - can_fail = resume; - break; - - case N_Empty: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - set_typ(n->type, null_bit); /* precompute type */ - can_fail = resume; - break; - - case N_Id: { - struct lentry *var; - - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - /* - * Precompute type - */ - var = LSym0(n); - if (var->flag & F_Global) - set_typ(n->type, frst_gbl + var->val.global->index); - else if (var->flag & F_Static) - set_typ(n->type, frst_gbl + var->val.index); - else - set_typ(n->type, frst_loc + var->val.index); - can_fail = resume; - } - break; - - case N_Field: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - can_fail = findloops(Tree0(n), resume, NULL); - n->symtyps = symtyps(1); - break; - - case N_If: - if (rslt_type == NULL) - rslt_type = alloc_typ(n_intrtyp); - n->type = rslt_type; - -#ifdef TypTrc - rslt_type = NULL; /* don't share result loc with subexpressions*/ -#endif /* TypTrc */ - /* - * control clause is bounded - */ - findloops(Tree0(n), 0, NULL); - can_fail = findloops(Tree1(n), resume, rslt_type); - if (Tree2(n)->n_type == N_Empty) - can_fail = 1; - else { - if (resume) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - can_fail |= findloops(Tree2(n), resume, rslt_type); - } - break; - - case N_Int: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - set_typ(n->type, int_bit); /* precompute type */ - can_fail = resume; - break; - - case N_Invok: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - nargs = Val0(n); /* number of arguments */ - /* - * Assume operation can suspend and fail. - */ - if (resume) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - can_fail = 1; - for (i = nargs; i >= 0; --i) - can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); - n->symtyps = symtyps(max_sym); - break; - - case N_InvOp: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - nargs = Val0(n); /* number of arguments */ - if (resume && Impl1(n)->ret_flag & DoesSusp) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (MightFail(Impl1(n)->ret_flag)) - can_fail = 1; - else - can_fail = resume; - for (i = nargs; i >= 1; --i) - can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); - n->symtyps = symtyps(n_arg_sym(Impl1(n))); - break; - - case N_InvProc: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - nargs = Val0(n); /* number of arguments */ - if (resume && Proc1(n)->ret_flag & DoesSusp) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (Proc1(n)->ret_flag & DoesFail) - can_fail = 1; - else - can_fail = resume; - for (i = nargs; i >= 1; --i) - can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); - break; - - case N_InvRec: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - nargs = Val0(n); /* number of args */ - if (err_conv) - can_fail = 1; - else - can_fail = resume; - for (i = nargs; i >= 1; --i) - can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); - break; - - case N_Limit: - findloops(Tree0(n), resume, rslt_type); - can_fail = findloops(Tree1(n), 1, NULL); - n->type = Tree0(n)->type; - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - n->symtyps = symtyps(1); - break; - - case N_Loop: { - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - loop_info.prev = cur_loop; - loop_info.resume = resume; - loop_info.can_fail = 0; - loop_info.every_cntrl = 0; - loop_info.type = n->type; - cur_loop = &loop_info; - switch ((int)Val0(Tree0(n))) { - case EVERY: - case SUSPEND: - /* - * The control clause can be resumed. The body is bounded. - */ - loop_info.every_cntrl = 1; - can_fail = findloops(Tree1(n), 1, NULL); - loop_info.every_cntrl = 0; - findloops(Tree2(n), 0, NULL); - break; - - case REPEAT: - /* - * The loop needs a saved store. The body is bounded. - */ - findloops(Tree1(n), 0, NULL); - can_fail = 0; - break; - - case WHILE: - /* - * The loop needs a saved store. The control - * clause and the body are each bounded. - */ - can_fail = findloops(Tree1(n), 0, NULL); - findloops(Tree2(n), 0, NULL); - break; - - case UNTIL: - /* - * The loop needs a saved store. The control - * clause and the body are each bounded. - */ - findloops(Tree1(n), 0, NULL); - findloops(Tree2(n), 0, NULL); - can_fail = 1; - break; - } - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (do_typinfer && resume) - n->store->next = alloc_stor(n_gbl + n_loc, n_icntyp); - can_fail |= cur_loop->can_fail; - cur_loop = cur_loop->prev; - } - break; - - case N_Next: - if (cur_loop == NULL) { - nfatal(n, "invalid context for next", NULL); - return 1; - } - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - can_fail = cur_loop->every_cntrl; - break; - - case N_Not: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - set_typ(n->type, null_bit); /* precompute type */ - /* - * The expression is bounded. - */ - findloops(Tree0(n), 0, NULL); - can_fail = 1; - break; - - case N_Real: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - set_typ(n->type, real_bit); /* precompute type */ - can_fail = resume; - break; - - case N_Ret: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - if (Val0(Tree0(n)) == RETURN) { - /* - * The expression is bounded. - */ - findloops(Tree1(n), 0, NULL); - } - can_fail = 0; - break; - - case N_Scan: { - struct implement *asgn_impl; - - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - n->symtyps = symtyps(1); - can_fail = resume; - if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) { - asgn_impl = optab[asgn_loc].binary; - if (resume && asgn_impl->ret_flag & DoesSusp) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (MightFail(asgn_impl->ret_flag)) - can_fail = 1; - n->symtyps->next = symtyps(n_arg_sym(asgn_impl)); - } - can_fail = findloops(Tree2(n), can_fail, NULL); /* body */ - can_fail = findloops(Tree1(n), can_fail, NULL); /* subject */ - } - break; - - case N_Sect: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - can_fail = resume; - /* - * Impl0(n) is sectioning. - */ - if (resume && Impl0(n)->ret_flag & DoesSusp) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (MightFail(Impl0(n)->ret_flag)) - can_fail = 1; - n->symtyps = symtyps(n_arg_sym(Impl0(n))); - if (Impl1(n) != NULL) { - /* - * Impl1(n) is plus or minus - */ - if (can_fail && Impl1(n)->ret_flag & DoesSusp && n->store == NULL) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (MightFail(Impl1(n)->ret_flag)) - can_fail = 1; - n->symtyps->next = symtyps(n_arg_sym(Impl1(n))); - } - can_fail = findloops(Tree4(n), can_fail, NULL); /* operand 3 */ - can_fail = findloops(Tree3(n), can_fail, NULL); /* operand 2 */ - can_fail = findloops(Tree2(n), can_fail, NULL); /* operand 1 */ - break; - - case N_Slist: - /* - * 1st expression is bounded. - */ - findloops(Tree0(n), 0, NULL); - can_fail = findloops(Tree1(n), resume, rslt_type); - n->type = Tree1(n)->type; - break; - - case N_SmplAsgn: - can_fail = findloops(Tree3(n), resume, NULL); /* 2nd operand */ - findloops(Tree2(n), can_fail, rslt_type); /* variable */ - n->type = Tree2(n)->type; - break; - - case N_SmplAug: - can_fail = resume; - /* - * Impl1(n) is the augmented operation. - */ - if (resume && Impl1(n)->ret_flag & DoesSusp) - n->store = alloc_stor(n_gbl + n_loc, n_icntyp); - if (MightFail(Impl1(n)->ret_flag)) - can_fail = 1; - can_fail = findloops(Tree3(n), can_fail, NULL); /* 2nd operand */ - findloops(Tree2(n), can_fail, rslt_type); /* variable */ - n->symtyps = symtyps(n_arg_sym(Impl1(n))); - n->type = Tree2(n)->type; - Typ4(n) = alloc_typ(n_intrtyp); - break; - - case N_Str: - if (rslt_type == NULL) - n->type = alloc_typ(n_intrtyp); - else - n->type = rslt_type; - set_typ(n->type, str_bit); /* precompute type */ - can_fail = resume; - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - if (can_fail) - n->flag = CanFail; - else - n->flag = 0; - return can_fail; - } - -/* - * symtyps - determine the number of entries needed for a symbol table - * that maps argument indexes to types for an operation in the - * data base. Allocate the symbol table. - */ -static struct symtyps *symtyps(nsyms) -int nsyms; - { - struct symtyps *tab; - - if (nsyms == 0) - return NULL; - -#ifdef OptimizeType - tab = (struct symtyps *)alloc((unsigned int)(sizeof(struct symtyps) + - (nsyms - 1) * sizeof(struct typinfo *))); -#else /* OptimizeType */ - tab = (struct symtyps *)alloc((unsigned int)(sizeof(struct symtyps) + - (nsyms - 1) * sizeof(int *))); -#endif /* OptimizeType */ - tab->nsyms = nsyms; - tab->next = NULL; - while (nsyms) - tab->types[--nsyms] = alloc_typ(n_intrtyp); - return tab; - } - -/* - * infer_proc - perform type inference on a call to an Icon procedure. - */ -static void infer_prc(proc, n) -struct pentry *proc; -nodeptr n; - { - struct store *s_store; - struct store *f_store; - struct store *store; - struct pentry *sv_proc; - struct t_coexpr *sv_coexp; - struct lentry *lptr; - nodeptr n1; - int i; - int nparams; - int coexp_bit; - - /* - * Determine what co-expressions the procedure might be called from. - */ - if (cur_coexp == NULL) - ChkMrgTyp(n_icntyp, cur_proc->coexprs, proc->coexprs) - else { - coexp_bit = type_array[coexp_typ].frst_bit + cur_coexp->typ_indx; - if (!bitset(proc->coexprs, coexp_bit)) { - ++changed; - set_typ(proc->coexprs, coexp_bit); - } - } - - proc->reachable = 1; /* this procedure can be called */ - - /* - * If this procedure can suspend, there may be backtracking paths - * to this invocation. If so, propagate types of globals from the - * backtracking paths to the suspends of the procedure and propagate - * types of locals to the success store of the call. - */ - if (proc->ret_flag & DoesSusp && n->store != NULL) { - for (i = 0; i < n_gbl; ++i) - ChkMrgTyp(n_icntyp, n->store->types[i], proc->susp_store->types[i]) - for (i = 0; i < n_loc; ++i) - MrgTyp(n_icntyp, n->store->types[n_gbl + i], succ_store->types[n_gbl + - i]) - } - - /* - * Merge the types of global variables into the "in store" of the - * procedure. Because the body of the procedure may already have - * been processed for this pass, the "changed" flag must be set if - * there is a change of type in the store. This will insure that - * there will be another iteration in which to propagate the change - * into the body. - */ - store = proc->in_store; - for (i = 0; i < n_gbl; ++i) - ChkMrgTyp(n_icntyp, succ_store->types[i], store->types[i]) - -#ifdef TypTrc - /* - * Trace the call. - */ - if (trcfile != NULL) - fprintf(trcfile, "%s (%d,%d) %s%s(", n->n_file, n->n_line, n->n_col, - trc_indent, proc->name); -#endif /* TypTrc */ - - /* - * Get the types of the arguments, starting with the non-varargs part. - */ - nparams = proc->nargs; /* number of parameters */ - if (nparams < 0) - nparams = -nparams - 1; - for (i = 0; i < num_args && i < nparams; ++i) { - typ_deref(arg_typs->types[i], store->types[n_gbl + i], 1); - -#ifdef TypTrc - if (trcfile != NULL) { - /* - * Trace the argument type to the call. - */ - if (i > 0) - fprintf(trcfile, ", "); - prt_d_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - } - - /* - * Get the type of the varargs part of the argument list. - */ - if (proc->nargs < 0) - while (i < num_args) { - typ_deref(arg_typs->types[i], - compnt_array[lst_elem].store->types[proc->arg_lst], 1); - -#ifdef TypTrc - if (trcfile != NULL) { - /* - * Trace the argument type to the call. - */ - if (i > 0) - fprintf(trcfile, ", "); - prt_d_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - ++i; - } - - /* - * Missing arguments have the null type. - */ - while (i < nparams) { - set_typ(store->types[n_gbl + i], null_bit); - ++i; - } - -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, ")\n"); - { - char *trc_ind_sav = trc_indent; - trc_indent = ""; /* staring a new procedure, don't indent tracing */ -#endif /* TypTrc */ - - /* - * only perform type inference on the body of a procedure - * once per iteration - */ - if (proc->iteration < iteration) { - proc->iteration = iteration; - s_store = succ_store; - f_store = fail_store; - sv_proc = cur_proc; - succ_store = cpy_store(proc->in_store); - cur_proc = proc; - sv_coexp = cur_coexp; - cur_coexp = NULL; /* we are not in a create expression */ - /* - * Perform type inference on the initial clause. Static variables - * are initialized to null on this path. - */ - for (lptr = proc->statics; lptr != NULL; lptr = lptr->next) - set_typ(succ_store->types[lptr->val.index], null_bit); - n1 = Tree1(proc->tree); - if (n1->flag & CanFail) { - /* - * The initial clause can fail. Because it is bounded, we need - * a new failure store that we can merge into the success store - * at the end of the clause. - */ - store = get_store(1); - fail_store = store; - infer_nd(n1); - mrg_store(store, succ_store); - free_store(store); - } - else - infer_nd(n1); - /* - * Perform type inference on the body of procedure. Execution may - * pass directly to it without executing initial clause. - */ - mrg_store(proc->in_store, succ_store); - n1 = Tree2(proc->tree); - if (n1->flag & CanFail) { - /* - * The body can fail. Because it is bounded, we need a new failure - * store that we can merge into the success store at the end of - * the procedure. - */ - store = get_store(1); - fail_store = store; - infer_nd(n1); - mrg_store(store, succ_store); - free_store(store); - } - else - infer_nd(n1); - set_ret(NULL); /* implicit fail */ - free_store(succ_store); - succ_store = s_store; - fail_store = f_store; - cur_proc = sv_proc; - cur_coexp = sv_coexp; - } - -#ifdef TypTrc - trc_indent = trc_ind_sav; - } -#endif /* TypTrc */ - - /* - * Get updated types for global variables at the end of the call. - */ - store = proc->out_store; - for (i = 0; i < n_gbl; ++i) - CpyTyp(n_icntyp, store->types[i], succ_store->types[i]); - - /* - * If the procedure can fail, merge variable types into the failure - * store. - */ - if (proc->ret_flag & DoesFail) - mrg_store(succ_store, fail_store); - - /* - * The return type of the procedure is the result type of the call. - */ - MrgTyp(n_intrtyp, proc->ret_typ, n->type); - } - -/* - * cpy_store - make a copy of a store. - */ -static struct store *cpy_store(source) -struct store *source; - { - struct store *dest; - int stor_sz; - int i; - - if (source == NULL) - dest = get_store(1); - else { - stor_sz = n_gbl + n_loc; - dest = get_store(0); - for (i = 0; i < stor_sz; ++i) - CpyTyp(n_icntyp, source->types[i], dest->types[i]) - } - return dest; - } - -/* - * mrg_store - merge the source store into the destination store. - */ -static void mrg_store(source, dest) -struct store *source; -struct store *dest; - { - int i; - - if (source == NULL) - return; - - /* - * Is this store included in the state that must be checked for a fixed - * point? - */ - if (dest->perm) { - for (i = 0; i < n_gbl + n_loc; ++i) - ChkMrgTyp(n_icntyp, source->types[i], dest->types[i]) - } - else { - for (i = 0; i < n_gbl + n_loc; ++i) - MrgTyp(n_icntyp, source->types[i], dest->types[i]) - } - } - -/* - * set_ret - Save return type and the store for global variables. - */ -static void set_ret(typ) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ - { - int i; - - /* - * Merge the return type into the type of the procedure, dereferencing - * locals in the process. - */ - if (typ != NULL) - deref_lcl(typ, cur_proc->ret_typ); - - /* - * Update the types that variables may have upon exit of the procedure. - */ - for (i = 0; i < n_gbl; ++i) - MrgTyp(n_icntyp, succ_store->types[i], cur_proc->out_store->types[i]); - } - -/* - * deref_lcl - dereference local variable sub-types. - */ -static void deref_lcl(src, dest) -#ifdef OptimizeType -struct typinfo *src; -struct typinfo *dest; -#else /* OptimizeType */ -unsigned int *src; -unsigned int *dest; -#endif /* OptimizeType */ - { - int i, j; - int ref_gbl; - int frst_stv; - int num_stv; - struct store *stv_stor; - struct type *wktyp; - - /* - * Make a copy of the type to be dereferenced. - */ - wktyp = get_wktyp(); - CpyTyp(n_intrtyp, src, wktyp->bits); - - /* - * Determine which variable types must be dereferenced. Merge the - * dereferenced type into the return type and delete the variable - * type. Start with simple local variables. - */ - for (i = 0; i < n_loc; ++i) - if (bitset(wktyp->bits, frst_loc + i)) { - MrgTyp(n_icntyp, succ_store->types[n_gbl + i], wktyp->bits) - clr_typ(wktyp->bits, frst_loc + i); - } - - /* - * Check for substring trapped variables. If a sub-string trapped - * variable references a local, add "string" to the return type. - * If a sub-string trapped variable references a global, leave the - * trapped variable in the return type. - * It is theoretically possible for a sub-string trapped variable type to - * reference both a local and a global. When the trapped variable type - * is returned to the calling procedure, the local is re-interpreted - * as a local of that procedure. This is a "valid" overestimate of - * of the semantics of the return. Because this is unlikely to occur - * in real programs, the overestimate is of no practical consequence. - */ - num_stv = type_array[stv_typ].num_bits; - frst_stv = type_array[stv_typ].frst_bit; - stv_stor = compnt_array[str_var].store; - for (i = 0; i < num_stv; ++i) { - if (bitset(wktyp->bits, frst_stv + i)) { - /* - * We have found substring trapped variable i, see whether it - * references locals or globals. Globals include structure - * element references. - */ - for (j = 0; j < n_loc; ++j) - if (bitset(stv_stor->types[i], frst_loc + j)) { - set_typ(wktyp->bits, str_bit); - break; - } - ref_gbl = 0; - for (j = n_icntyp; j < frst_loc; ++j) - if (bitset(stv_stor->types[i], j)) { - ref_gbl = 1; - break; - } - /* - * Keep the trapped variable only if it references globals. - */ - if (!ref_gbl) - clr_typ(wktyp->bits, frst_stv + i); - } - } - - /* - * Merge the types into the destination. - */ - MrgTyp(n_intrtyp, wktyp->bits, dest); - -#ifdef TypTrc - if (trcfile != NULL) { - prt_typ(trcfile, wktyp->bits); - fprintf(trcfile, "\n"); - } -#endif /* TypTrc */ - - free_wktyp(wktyp); - } - -/* - * get_store - get a store large enough to hold globals and locals. - */ -static struct store *get_store(clear) -int clear; - { - struct store *store; - int store_sz; - int i; - - /* - * Warning, stores for all procedures must be the same size. In some - * situations involving sub-string trapped variables (for example - * when using the "default" trapped variable) a referenced local variable - * type may be interpreted in a procedure to which it does not belong. - * This represents an impossible execution and type inference may - * "legally" produce any results for this part of the abstract - * interpretation. As long as the store is large enough to include any - * such "impossible" variables, type inference will do something legal. - * Note that n_loc is the maximum number of locals in any procedure, - * so store_sz is large enough. - */ - store_sz = n_gbl + n_loc; - if ((store = store_pool) == NULL) { - store = alloc_stor(store_sz, n_icntyp); - store->perm = 0; - } - else { - store_pool = store_pool->next; - /* - * See if the variables in the store should be initialized to the - * empty type. - */ - if (clear) - for (i = 0; i < store_sz; ++i) - ClrTyp(n_icntyp, store->types[i]); - } - return store; - } - -static void free_store(store) -struct store *store; - { - store->next = store_pool; - store_pool = store; - } - -/* - * infer_nd - perform type inference on a subtree of the syntax tree. - */ -static void infer_nd(n) -nodeptr n; - { - struct node *cases; - struct node *clause; - struct store *s_store; - struct store *f_store; - struct store *store; - struct loop { - struct store *succ_store; - struct store *fail_store; - struct store *next_store; - struct store *susp_store; - struct loop *prev; - } loop_info; - struct loop *loop_sav; - static struct loop *cur_loop; - struct argtyps *sav_argtyp; - int sav_nargs; - struct type *wktyp; - int i; - - switch (n->n_type) { - case N_Activat: - infer_act(n); - break; - - case N_Alt: - f_store = fail_store; - store = get_store(1); - fail_store = store; - infer_nd(Tree0(n)); /* 1st alternative */ - - /* - * "Correct" type inferencing of alternation has a performance - * problem. Propagating stores through nested alternation - * requires as many iterations as the depth of the nesting. - * This is solved by adding two edges to the flow graph. These - * represent impossible execution paths but this does not - * affect the soundness of type inferencing and, in "real" - * programs, does not affect the preciseness of its inference. - * One edge is directly from the 1st alternative to the 2nd. - * The other is a backtracking edge immediately back into - * the alternation from the 1st alternative. - */ - mrg_store(succ_store, store); /* imaginary edge to 2nd alternative */ - - if (n->store != NULL) { - mrg_store(succ_store, n->store); /* imaginary backtracking edge */ - mrg_store(n->store, fail_store); - } - s_store = succ_store; - succ_store = store; - fail_store = f_store; - infer_nd(Tree1(n)); /* 2nd alternative */ - mrg_store(s_store, succ_store); - free_store(s_store); - if (n->store != NULL) - mrg_store(n->store, fail_store); - fail_store = n->store; -#ifdef TypTrc - MrgTyp(n_intrtyp, Tree0(n)->type, n->type); - MrgTyp(n_intrtyp, Tree1(n)->type, n->type); -#else /* TypTrc */ - /* - * Type is computed by sub-expressions directly into n->type. - */ -#endif /* TypTrc */ - break; - - case N_Apply: { - struct type *lst_types; - int frst_lst; - int num_lst; - struct store *lstel_stor; - - infer_nd(Tree0(n)); /* thing being invoked */ - infer_nd(Tree1(n)); /* list */ - - frst_lst = type_array[list_typ].frst_bit; - num_lst = type_array[list_typ].num_bits; - lstel_stor = compnt_array[lst_elem].store; - - /* - * All that is available is a "summary" of the types of the - * elements of the list. Each argument to the invocation - * could be any type in the summary. Set up a maximum length - * argument list. - */ - lst_types = get_wktyp(); - typ_deref(Tree1(n)->type, lst_types->bits, 0); - wktyp = get_wktyp(); - for (i = 0; i < num_lst; ++i) - if (bitset(lst_types->bits, frst_lst + i)) - MrgTyp(n_icntyp, lstel_stor->types[i], wktyp->bits); - bitset(wktyp->bits, null_bit); /* arg list extension might be done */ - - sav_nargs = num_args; - sav_argtyp = arg_typs; - num_args = max_prm; - arg_typs = get_argtyp(); - for (i = 0; i < max_prm; ++i) - arg_typs->types[i] = wktyp->bits; - gen_inv(Tree0(n)->type, n); /* inference on general invocation */ - - free_wktyp(wktyp); - free_wktyp(lst_types); - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - } - break; - - case N_Augop: - infer_nd(Tree2(n)); /* 1st operand */ - infer_nd(Tree3(n)); /* 2nd operand */ - /* - * Perform type inference on the operation. - */ - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = 2; - arg_typs->types[0] = Tree2(n)->type; - arg_typs->types[1] = Tree3(n)->type; - infer_impl(Impl1(n), n, n->symtyps, Typ4(n)); - chk_succ(Impl1(n)->ret_flag, n->store); - /* - * Perform type inference on the assignment. - */ - arg_typs->types[1] = Typ4(n); - infer_impl(Impl0(n), n, n->symtyps->next, n->type); - chk_succ(Impl0(n)->ret_flag, n->store); - - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - break; - - case N_Bar: - /* - * This operation intercepts failure and has an associated - * resumption store. If backtracking reaches this operation - * execution may either continue backward or proceed forward - * again. - */ - mrg_store(n->store, fail_store); - mrg_store(n->store, succ_store); - fail_store = n->store; - infer_nd(Tree0(n)); - /* - * Type is computed by operand. - */ - break; - - case N_Break: - /* - * The success and failure stores for the operand of break are - * those associated with the enclosing loop. - */ - fail_store = cur_loop->fail_store; - loop_sav = cur_loop; - cur_loop = cur_loop->prev; - infer_nd(Tree0(n)); - cur_loop = loop_sav; - mrg_store(succ_store, cur_loop->succ_store); - if (cur_loop->susp_store != NULL) - mrg_store(cur_loop->susp_store, fail_store); - free_store(succ_store); - succ_store = get_store(1); /* empty store says: can't get past here */ - fail_store = dummy_stor; /* shouldn't be used */ - /* - * Result of break is empty type. Result type of expression - * is computed directly into result type of loop. - */ - break; - - case N_Case: - f_store = fail_store; - s_store = get_store(1); - infer_nd(Tree0(n)); /* control clause */ - cases = Tree1(n); - while (cases != NULL) { - if (cases->n_type == N_Ccls) { - clause = cases; - cases = NULL; - } - else { - clause = Tree1(cases); - cases = Tree0(cases); - } - - /* - * Set up a failure store to capture the effects of failure - * of the selection clause. - */ - store = get_store(1); - fail_store = store; - infer_nd(Tree0(clause)); /* value of clause */ - - /* - * Create the effect of the possible failure of the comparison - * of the selection value to the control value. - */ - mrg_store(succ_store, fail_store); - - /* - * The success and failure stores and the result of the body - * of the clause are those of the whole case expression. - */ - fail_store = f_store; - infer_nd(Tree1(clause)); /* body of clause */ - mrg_store(succ_store, s_store); - free_store(succ_store); - succ_store = store; - if (n->store != NULL) - mrg_store(n->store, fail_store); /* 'case' can be resumed */ -#ifdef TypTrc - MrgTyp(n_intrtyp, Tree1(clause)->type, n->type); -#else /* TypTrc */ - /* - * Type is computed by case clause directly into n->type. - */ -#endif /* TypTrc */ - } - - /* - * Check for default clause. - */ - if (Tree2(n) == NULL) - mrg_store(succ_store, f_store); - else { - fail_store = f_store; - infer_nd(Tree2(n)); /* default */ - mrg_store(succ_store, s_store); - if (n->store != NULL) - mrg_store(n->store, fail_store); /* 'case' can be resumed */ -#ifdef TypTrc - MrgTyp(n_intrtyp, Tree2(n)->type, n->type); -#else /* TypTrc */ - /* - * Type is computed by default clause directly into n->type. - */ -#endif /* TypTrc */ - } - free_store(succ_store); - succ_store = s_store; - if (n->store != NULL) - fail_store = n->store; - break; - - case N_Create: - /* - * Record initial values of local variables for coexpression. - */ - store = coexp_map[n->new_types[0]]->in_store; - for (i = 0; i < n_loc; ++i) - ChkMrgTyp(n_icntyp, succ_store->types[n_gbl + i], - store->types[n_gbl + i]) - /* - * Type is precomputed. - */ - break; - - case N_Cset: - case N_Empty: - case N_Id: - case N_Int: - case N_Real: - case N_Str: - /* - * Type is precomputed. - */ - break; - - case N_Field: { - struct fentry *fp; - struct par_rec *rp; - int frst_rec; - - if ((fp = flookup(Str0(Tree1(n)))) == NULL) { - break; /* error message printed elsewhere */ - } - - /* - * Determine the record types. - */ - infer_nd(Tree0(n)); - typ_deref(Tree0(n)->type, n->symtyps->types[0], 0); - - /* - * For each record containing this field, get the tupe of - * the field in that record. - */ - frst_rec = type_array[rec_typ].frst_bit; - for (rp = fp->rlist; rp != NULL; rp = rp->next) { - if (bitset(n->symtyps->types[0], frst_rec + rp->rec->rec_num)) - set_typ(n->type, frst_fld + rp->rec->frst_fld + rp->offset); - } - } - break; - - case N_If: - f_store = fail_store; - if (Tree2(n)->n_type != N_Empty) { - /* - * If there is an else clause, we must set up a failure store - * to capture the effects of failure of the control clause. - */ - store = get_store(1); - fail_store = store; - } - - infer_nd(Tree0(n)); /* control clause */ - - /* - * If the control clause succeeds, execution passes into the - * then clause with the failure store for the entire if expression. - */ - fail_store = f_store; - infer_nd(Tree1(n)); /* then clause */ - - if (Tree2(n)->n_type != N_Empty) { - if (n->store != NULL) - mrg_store(n->store, fail_store); /* 'if' expr can be resumed */ - s_store = succ_store; - - /* - * The entering success store of the else clause is the failure - * store of the control clause. The failure store is that of - * the entire if expression. - */ - succ_store = store; - fail_store = f_store; - infer_nd(Tree2(n)); /* else clause */ - - if (n->store != NULL) { - mrg_store(n->store, fail_store); /* 'if' expr can be resumed */ - fail_store = n->store; - } - - /* - * Join the exiting success stores of the then and else clauses. - */ - mrg_store(s_store, succ_store); - free_store(s_store); - } - -#ifdef TypTrc - MrgTyp(n_intrtyp, Tree1(n)->type, n->type); - if (Tree2(n)->n_type != N_Empty) - MrgTyp(n_intrtyp, Tree2(n)->type, n->type); -#else /* TypTrc */ - /* - * Type computed by 'then' and 'else' clauses directly into n->type. - */ -#endif /* TypTrc */ - break; - - case N_Invok: - /* - * General invocation. - */ - infer_nd(Tree1(n)); /* thing being invoked */ - - /* - * Perform type inference on all the arguments and copy the - * results into the argument type array. - */ - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = Val0(n); /* number of arguments */ - for (i = 0; i < num_args; ++i) { - infer_nd(n->n_field[i+2].n_ptr); /* arg i */ - arg_typs->types[i] = n->n_field[i+2].n_ptr->type; - } - - /* - * If this is mutual evaluation, get the type of the last argument, - * otherwise do inference on general invocation. - */ - if (Tree1(n)->n_type == N_Empty) { - MrgTyp(n_intrtyp, arg_typs->types[num_args - 1], n->type); - } - else - gen_inv(Tree1(n)->type, n); - - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - break; - - case N_InvOp: - /* - * Invocation of a run-time operation. Perform inference on all - * the arguments, copying the results into the argument type - * array. - */ - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = Val0(n); /* number of arguments */ - for (i = 0; i < num_args; ++i) { - infer_nd(n->n_field[i+2].n_ptr); /* arg i */ - arg_typs->types[i] = n->n_field[i+2].n_ptr->type; - } - - /* - * Perform inference on operation invocation. - */ - infer_impl(Impl1(n), n, n->symtyps, n->type); - chk_succ(Impl1(n)->ret_flag, n->store); - - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - break; - - case N_InvProc: - /* - * Invocation of a procedure. Perform inference on all - * the arguments, copying the results into the argument type - * array. - */ - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = Val0(n); /* number of arguments */ - for (i = 0; i < num_args; ++i) { - infer_nd(n->n_field[i+2].n_ptr); /* arg i */ - arg_typs->types[i] = n->n_field[i+2].n_ptr->type; - } - - /* - * Perform inference on the procedure invocation. - */ - infer_prc(Proc1(n), n); - chk_succ(Proc1(n)->ret_flag, n->store); - - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - break; - - case N_InvRec: - /* - * Invocation of a record constructor. Perform inference on all - * the arguments, copying the results into the argument type - * array. - */ - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = Val0(n); /* number of arguments */ - for (i = 0; i < num_args; ++i) { - infer_nd(n->n_field[i+2].n_ptr); /* arg i */ - arg_typs->types[i] = n->n_field[i+2].n_ptr->type; - } - - infer_con(Rec1(n), n); /* inference on constructor invocation */ - - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - break; - - case N_Limit: - infer_nd(Tree1(n)); /* limit */ - typ_deref(Tree1(n)->type, n->symtyps->types[0], 0); - mrg_store(succ_store, fail_store); /* limit might be 0 */ - mrg_store(n->store, fail_store); /* resumption may bypass expr */ - infer_nd(Tree0(n)); /* expression */ - if (fail_store != NULL) - mrg_store(n->store, fail_store); /* expression may be resumed */ - fail_store = n->store; - /* - * Type is computed by expression being limited. - */ - break; - - case N_Loop: { - /* - * Establish stores used by break and next. - */ - loop_info.prev = cur_loop; - loop_info.succ_store = get_store(1); - loop_info.fail_store = fail_store; - loop_info.next_store = NULL; - loop_info.susp_store = n->store->next; - cur_loop = &loop_info; - - switch ((int)Val0(Tree0(n))) { - case EVERY: - infer_nd(Tree1(n)); /* control clause */ - f_store = fail_store; - - /* - * Next in the do clause resumes the control clause as - * does success of the do clause. - */ - loop_info.next_store = fail_store; - infer_nd(Tree2(n)); /* do clause */ - mrg_store(succ_store, f_store); - break; - - case REPEAT: - /* - * The body of the loop can be entered by entering the - * loop, by executing a next in the body, or by having - * the loop succeed or fail. n->store captures all but - * the first case, which is covered by the initial success - * store. - */ - fail_store = n->store; - mrg_store(n->store, succ_store); - loop_info.next_store = n->store; - infer_nd(Tree1(n)); - mrg_store(succ_store, n->store); - break; - - case SUSPEND: - infer_nd(Tree1(n)); /* value */ -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, "%s (%d,%d) suspend ", n->n_file, n->n_line, - n->n_col); -#endif /* TypTrc */ - - set_ret(Tree1(n)->type); /* set return type of procedure */ - - /* - * Get changes to types of global variables from - * resumption. - */ - store = cur_proc->susp_store; - for (i = 0; i < n_gbl; ++i) - CpyTyp(n_icntyp, store->types[i], succ_store->types[i]); - - /* - * Next in the do clause resumes the control clause as - * does success of the do clause. - */ - f_store = fail_store; - loop_info.next_store = fail_store; - infer_nd(Tree2(n)); /* do clause */ - mrg_store(succ_store, f_store); - break; - - case WHILE: - /* - * The control clause can be entered by entering the loop, - * executing a next expression, or by having the do clause - * succeed or fail. n->store captures all but the first case, - * which is covered by the initial success store. - */ - mrg_store(n->store, succ_store); - loop_info.next_store = n->store; - infer_nd(Tree1(n)); /* control clause */ - fail_store = n->store; - infer_nd(Tree2(n)); /* do clause */ - mrg_store(succ_store, n->store); - break; - - case UNTIL: - /* - * The control clause can be entered by entering the loop, - * executing a next expression, or by having the do clause - * succeed or fail. n->store captures all but the first case, - * which is covered by the initial success store. - */ - mrg_store(n->store, succ_store); - loop_info.next_store = n->store; - f_store = fail_store; - /* - * Set up a failure store to capture the effects of failure - * of the control clause. - */ - store = get_store(1); - fail_store = store; - infer_nd(Tree1(n)); /* control clause */ - mrg_store(succ_store, f_store); - free_store(succ_store); - succ_store = store; - fail_store = n->store; - infer_nd(Tree2(n)); /* do clause */ - mrg_store(succ_store, n->store); - break; - } - free_store(succ_store); - succ_store = loop_info.succ_store; - if (n->store->next != NULL) - fail_store = n->store->next; - cur_loop = cur_loop->prev; - /* - * Type is computed by break expressions. - */ - } - break; - - case N_Next: - if (cur_loop->next_store == NULL) - mrg_store(succ_store, fail_store); /* control clause of every */ - else - mrg_store(succ_store, cur_loop->next_store); - free_store(succ_store); - succ_store = get_store(1); /* empty store says: can't get past here */ - fail_store = dummy_stor; /* shouldn't be used */ - /* - * Result is empty type. - */ - break; - - case N_Not: - /* - * Set up a failure store to capture the effects of failure - * of the negated expression, it becomes the success store - * of the entire expression. - */ - f_store = fail_store; - store = get_store(1); - fail_store = store; - infer_nd(Tree0(n)); - mrg_store(succ_store, f_store); /* if success, then fail */ - free_store(succ_store); - succ_store = store; - fail_store = f_store; - /* - * Type is precomputed. - */ - break; - - case N_Ret: - if (Val0(Tree0(n)) == RETURN) { - if (Tree1(n)->flag & CanFail) { - /* - * Set up a failure store to capture the effects of failure - * of the returned expression and the corresponding procedure - * failure. - */ - store = get_store(1); - fail_store = store; - infer_nd(Tree1(n)); /* return value */ - mrg_store(store, succ_store); - free_store(store); - } - else - infer_nd(Tree1(n)); /* return value */ - -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, "%s (%d,%d) return ", n->n_file, n->n_line, - n->n_col); -#endif /* TypTrc */ - - set_ret(Tree1(n)->type); - } - else { /* fail */ - set_ret(NULL); - -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, "%s (%d,%d) fail\n", n->n_file, n->n_line, - n->n_col); -#endif /* TypTrc */ - - } - free_store(succ_store); - succ_store = get_store(1); /* empty store says: can't get past here */ - fail_store = dummy_stor; /* shouldn't be used */ - /* - * Empty type. - */ - break; - - case N_Scan: { - struct implement *asgn_impl; - - infer_nd(Tree1(n)); /* subject */ - typ_deref(Tree1(n)->type, n->symtyps->types[0], 0); - infer_nd(Tree2(n)); /* body */ - - if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) { - /* - * Perform type inference on the assignment. - */ - asgn_impl = optab[asgn_loc].binary; - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = 2; - arg_typs->types[0] = Tree1(n)->type; - arg_typs->types[1] = Tree2(n)->type; - infer_impl(asgn_impl, n, n->symtyps->next, n->type); - chk_succ(asgn_impl->ret_flag, n->store); - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - } - else - MrgTyp(n_intrtyp, Tree2(n)->type, n->type); - } - break; - - case N_Sect: - infer_nd(Tree2(n)); /* 1st operand */ - infer_nd(Tree3(n)); /* 2nd operand */ - infer_nd(Tree4(n)); /* 3rd operand */ - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - if (Impl1(n) != NULL) { - /* - * plus or minus. - */ - num_args = 2; - arg_typs->types[0] = Tree3(n)->type; - arg_typs->types[1] = Tree4(n)->type; - wktyp = get_wktyp(); - infer_impl(Impl1(n), n, n->symtyps->next, wktyp->bits); - chk_succ(Impl1(n)->ret_flag, n->store); - arg_typs->types[2] = wktyp->bits; - } - else - arg_typs->types[2] = Tree4(n)->type; - num_args = 3; - arg_typs->types[0] = Tree2(n)->type; - arg_typs->types[1] = Tree3(n)->type; - /* - * sectioning - */ - infer_impl(Impl0(n), n, n->symtyps, n->type); - chk_succ(Impl0(n)->ret_flag, n->store); - if (Impl1(n) != NULL) - free_wktyp(wktyp); - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - break; - - case N_Slist: - f_store = fail_store; - if (Tree0(n)->flag & CanFail) { - /* - * Set up a failure store to capture the effects of failure - * of the first operand; this is merged into the - * incoming success store of the second operand. - */ - store = get_store(1); - fail_store = store; - infer_nd(Tree0(n)); - mrg_store(store, succ_store); - free_store(store); - } - else - infer_nd(Tree0(n)); - fail_store = f_store; - infer_nd(Tree1(n)); - /* - * Type is computed by second operand. - */ - break; - - case N_SmplAsgn: { - /* - * Optimized assignment to a named variable. - */ - struct lentry *var; - int indx; - - infer_nd(Tree3(n)); - var = LSym0(Tree2(n)); - if (var->flag & F_Global) - indx = var->val.global->index; - else if (var->flag & F_Static) - indx = var->val.index; - else - indx = n_gbl + var->val.index; - ClrTyp(n_icntyp, succ_store->types[indx]); - typ_deref(Tree3(n)->type, succ_store->types[indx], 0); - -#ifdef TypTrc - /* - * Trace assignment. - */ - if (trcfile != NULL) { - fprintf(trcfile, "%s (%d,%d) %s%s := ", n->n_file, n->n_line, - n->n_col, trc_indent, var->name); - prt_d_typ(trcfile, Tree3(n)->type); - fprintf(trcfile, "\n"); - } -#endif /* TypTrc */ - /* - * Type is precomputed. - */ - } - break; - - case N_SmplAug: { - /* - * Optimized augmented assignment to a named variable. - */ - struct lentry *var; - int indx; - - /* - * Perform type inference on the operation. - */ - infer_nd(Tree3(n)); /* 2nd operand */ - - /* - * Set up type array for arguments of operation. - */ - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = 2; - arg_typs->types[0] = Tree2(n)->type; /* type was precomputed */ - arg_typs->types[1] = Tree3(n)->type; - - /* - * Perform inference on the operation. - */ - infer_impl(Impl1(n), n, n->symtyps, Typ4(n)); - chk_succ(Impl1(n)->ret_flag, n->store); - - /* - * Perform assignment to the variable. - */ - var = LSym0(Tree2(n)); - if (var->flag & F_Global) - indx = var->val.global->index; - else if (var->flag & F_Static) - indx = var->val.index; - else - indx = n_gbl + var->val.index; - ClrTyp(n_icntyp, succ_store->types[indx]); - typ_deref(Typ4(n), succ_store->types[indx], 0); - -#ifdef TypTrc - /* - * Trace assignment. - */ - if (trcfile != NULL) { - fprintf(trcfile, "%s (%d,%d) %s%s := ", n->n_file, n->n_line, - n->n_col, trc_indent, var->name); - prt_d_typ(trcfile, Typ4(n)); - fprintf(trcfile, "\n"); - } -#endif /* TypTrc */ - - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - - /* - * Type is precomputed. - */ - } - break; - - default: - fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); - exit(EXIT_FAILURE); - } - } - -/* - * infer_con - perform type inference for the invocation of a record - * constructor. - */ -static void infer_con(rec, n) -struct rentry *rec; -nodeptr n; - { - int fld_indx; - int nfields; - int i; - -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, "%s (%d,%d) %s%s(", n->n_file, n->n_line, n->n_col, - trc_indent, rec->name); -#endif /* TypTrc */ - - /* - * Dereference argument types into appropriate entries of field store. - */ - fld_indx = rec->frst_fld; - nfields = rec->nfields; - for (i = 0; i < num_args && i < nfields; ++i) { - typ_deref(arg_typs->types[i], fld_stor->types[fld_indx++], 1); - -#ifdef TypTrc - if (trcfile != NULL) { - if (i > 0) - fprintf(trcfile, ", "); - prt_d_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - } - - /* - * If there are too few arguments, add null type to appropriate entries - * of field store. - */ - while (i < nfields) { - if (!bitset(fld_stor->types[fld_indx], null_bit)) { - ++changed; - set_typ(fld_stor->types[fld_indx], null_bit); - } - ++fld_indx; - ++i; - } - - /* - * return record type - */ - set_typ(n->type, type_array[rec_typ].frst_bit + rec->rec_num); - -#ifdef TypTrc - if (trcfile != NULL) { - fprintf(trcfile, ") =>> "); - prt_typ(trcfile, n->type); - fprintf(trcfile, "\n"); - } -#endif /* TypTrc */ - } - -/* - * infer_act - perform type inference on coexpression activation. - */ -static void infer_act(n) -nodeptr n; - { - struct implement *asgn_impl; - struct store *s_store; - struct store *f_store; - struct store *e_store; - struct store *store; - struct t_coexpr *sv_coexp; - struct t_coexpr *coexp; - struct type *rslt_typ; - struct argtyps *sav_argtyp; - int frst_coexp; - int num_coexp; - int sav_nargs; - int i; - int j; - -#ifdef TypTrc - FILE *trc_save; -#endif /* TypTrc */ - - num_coexp = type_array[coexp_typ].num_bits; - frst_coexp = type_array[coexp_typ].frst_bit; - - infer_nd(Tree1(n)); /* value to transmit */ - infer_nd(Tree2(n)); /* coexpression */ - - /* - * Dereference the two arguments. Note that only locals in the - * transmitted value are dereferenced. - */ - -#ifdef TypTrc - trc_save = trcfile; - trcfile = NULL; /* don't trace value during dereferencing */ -#endif /* TypTrc */ - - deref_lcl(Tree1(n)->type, n->symtyps->types[0]); - -#ifdef TypTrc - trcfile = trc_save; -#endif /* TypTrc */ - - typ_deref(Tree2(n)->type, n->symtyps->types[1], 0); - - rslt_typ = get_wktyp(); - - /* - * Set up a store for the end of the activation and propagate local - * variables across the activation; the activation may succeed or - * fail. - */ - e_store = get_store(1); - for (i = 0; i < n_loc; ++i) - CpyTyp(n_icntyp, succ_store->types[n_gbl + i], e_store->types[n_gbl + i]) - if (fail_store->perm) { - for (i = 0; i < n_loc; ++i) - ChkMrgTyp(n_icntyp, succ_store->types[n_gbl + i], - fail_store->types[n_gbl + i]) - } - else { - for (i = 0; i < n_loc; ++i) - MrgTyp(n_icntyp, succ_store->types[n_gbl + i], - fail_store->types[n_gbl + i]) - } - - - /* - * Go through all the co-expressions that might be activated, - * perform type inference on them, and transmit stores along - * the execution paths induced by the activation. - */ - s_store = succ_store; - f_store = fail_store; - for (j = 0; j < num_coexp; ++j) { - if (bitset(n->symtyps->types[1], frst_coexp + j)) { - coexp = coexp_map[j]; - /* - * Merge the types of global variables into the "in store" of the - * co-expression. Because the body of the co-expression may already - * have been processed for this pass, the "changed" flag must be - * set if there is a change of type in the store. This will insure - * that there will be another iteration in which to propagate the - * change into the body. - */ - store = coexp->in_store; - for (i = 0; i < n_gbl; ++i) - ChkMrgTyp(n_icntyp, s_store->types[i], store->types[i]) - - ChkMrgTyp(n_intrtyp, n->symtyps->types[0], coexp->act_typ) - - /* - * Only perform type inference on the body of a co-expression - * once per iteration. The main co-expression has no body. - */ - if (coexp->iteration < iteration & coexp->n != NULL) { - coexp->iteration = iteration; - succ_store = cpy_store(coexp->in_store); - fail_store = coexp->out_store; - sv_coexp = cur_coexp; - cur_coexp = coexp; - infer_nd(coexp->n); - - /* - * Dereference the locals in the value resulting from - * the execution of the co-expression body. - */ - -#ifdef TypTrc - if (trcfile != NULL) - fprintf(trcfile, "%s (%d,%d) %sC%d =>> ", coexp->n->n_file, - coexp->n->n_line, coexp->n->n_col, trc_indent, j); -#endif /* TypTrc */ - - deref_lcl(coexp->n->type, coexp->rslt_typ); - - mrg_store(succ_store, coexp->out_store); - free_store(succ_store); - cur_coexp = sv_coexp; - } - - /* - * Get updated types for global variables, assuming the co-expression - * fails or returns by completing. - */ - store = coexp->out_store; - for (i = 0; i < n_gbl; ++i) - MrgTyp(n_icntyp, store->types[i], e_store->types[i]); - if (f_store->perm) { - for (i = 0; i < n_gbl; ++i) - ChkMrgTyp(n_icntyp, store->types[i], f_store->types[i]); - } - else { - for (i = 0; i < n_gbl; ++i) - MrgTyp(n_icntyp, store->types[i], f_store->types[i]); - } - MrgTyp(n_intrtyp, coexp->rslt_typ, rslt_typ->bits) - } - } - - /* - * Control may return from the activation if another co-expression - * activates the current one. If we are in a create expression, - * cur_coexp is the current co-expression, otherwise the current - * procedure may be called within several co-expressions. - */ - if (cur_coexp == NULL) { - for (j = 0; j < num_coexp; ++j) - if (bitset(cur_proc->coexprs, frst_coexp + j)) - mrg_act(coexp_map[j], e_store, rslt_typ); - } - else - mrg_act(cur_coexp, e_store, rslt_typ); - - free_store(s_store); - succ_store = e_store; - fail_store = f_store; - - -#ifdef TypTrc - if (trcfile != NULL) { - fprintf(trcfile, "%s (%d,%d) %s", n->n_file, n->n_line, n->n_col, - trc_indent); - prt_typ(trcfile, n->symtyps->types[0]); - fprintf(trcfile, " @ "); - prt_typ(trcfile, n->symtyps->types[1]); - fprintf(trcfile, " =>> "); - prt_typ(trcfile, rslt_typ->bits); - fprintf(trcfile, "\n"); - } -#endif /* TypTrc */ - - if (optab[Val0(Tree0(n))].tok.t_type == AUGAT) { - /* - * Perform type inference on the assignment. - */ - asgn_impl = optab[asgn_loc].binary; - sav_argtyp = arg_typs; - sav_nargs = num_args; - arg_typs = get_argtyp(); - num_args = 2; - arg_typs->types[0] = Tree1(n)->type; - arg_typs->types[1] = rslt_typ->bits; - infer_impl(asgn_impl, n, n->symtyps->next, n->type); - chk_succ(asgn_impl->ret_flag, n->store); - free_argtyp(arg_typs); - arg_typs = sav_argtyp; - num_args = sav_nargs; - } - else - ChkMrgTyp(n_intrtyp, rslt_typ->bits, n->type) - - free_wktyp(rslt_typ); - } - -/* - * mrg_act - merge entry information for the co-expression to the - * the ending store and result type for the activation being - * analyzed. - */ -static void mrg_act(coexp, e_store, rslt_typ) -struct t_coexpr *coexp; -struct store *e_store; -struct type *rslt_typ; - { - struct store *store; - int i; - - store = coexp->in_store; - for (i = 0; i < n_gbl; ++i) - MrgTyp(n_icntyp, store->types[i], e_store->types[i]); - - MrgTyp(n_intrtyp, coexp->act_typ, rslt_typ->bits) - } - -/* - * typ_deref - perform dereferencing in the abstract type realm. - */ -static void typ_deref(src, dest, chk) -#ifdef OptimizeType -struct typinfo *src; -struct typinfo *dest; -#else /* OptimizeType */ -unsigned int *src; -unsigned int *dest; -#endif /* OptimizeType */ -int chk; - { - struct store *tblel_stor; - struct store *tbldf_stor; - struct store *ttv_stor; - struct store *store; - unsigned int old; - int num_tbl; - int frst_tbl; - int num_bits; - int frst_bit; - int i; - int j; - int ret; -/* - if (src->bits == NULL) { - src->bits = alloc_mem_typ(src->size); - xfer_packed_types(src); - } - if (dest->bits == NULL) { - dest->bits = alloc_mem_typ(dest->size); - xfer_packed_types(dest); - } -*/ - /* - * copy values to destination - */ -#ifdef OptimizeType - if ((src->bits != NULL) && (dest->bits != NULL)) { - for (i = 0; i < NumInts(n_icntyp) - 1; ++i) { - old = dest->bits[i]; - dest->bits[i] |= src->bits[i]; - if (chk && (old != dest->bits[i])) - ++changed; - } - old = dest->bits[i]; - dest->bits[i] |= src->bits[i] & val_mask; /* mask out variables */ - if (chk && (old != dest->bits[i])) - ++changed; - } - else if ((src->bits != NULL) && (dest->bits == NULL)) { - dest->bits = alloc_mem_typ(DecodeSize(dest->packed)); - xfer_packed_types(dest); - for (i = 0; i < NumInts(n_icntyp) - 1; ++i) { - old = dest->bits[i]; - dest->bits[i] |= src->bits[i]; - if (chk && (old != dest->bits[i])) - ++changed; - } - old = dest->bits[i]; - dest->bits[i] |= src->bits[i] & val_mask; /* mask out variables */ - if (chk && (old != dest->bits[i])) - ++changed; - } - else if ((src->bits == NULL) && (dest->bits != NULL)) { - ret = xfer_packed_to_bits(src, dest, n_icntyp); - if (chk) - changed += ret; - } - else { - ret = mrg_packed_to_packed(src, dest, n_icntyp); - if (chk) - changed += ret; - } -#else /* OptimizeType */ - for (i = 0; i < NumInts(n_icntyp) - 1; ++i) { - old = dest[i]; - dest[i] |= src[i]; - if (chk && (old != dest[i])) - ++changed; - } - old = dest[i]; - dest[i] |= src[i] & val_mask; /* mask out variables */ - if (chk && (old != dest[i])) - ++changed; -#endif /* OptimizeType */ - - /* - * predefined variables whose types do not change. - */ - for (i = 0; i < num_typs; ++i) { - if (icontypes[i].deref == DrfCnst) { - if (bitset(src, type_array[i].frst_bit)) - if (chk) - ChkMrgTyp(n_icntyp, type_array[i].typ, dest) - else - MrgTyp(n_icntyp, type_array[i].typ, dest) - } - } - - - /* - * substring trapped variables - */ - num_bits = type_array[stv_typ].num_bits; - frst_bit = type_array[stv_typ].frst_bit; - for (i = 0; i < num_bits; ++i) - if (bitset(src, frst_bit + i)) - if (!bitset(dest, str_bit)) { - if (chk) - ++changed; - set_typ(dest, str_bit); - } - - /* - * table element trapped variables - */ - num_bits = type_array[ttv_typ].num_bits; - frst_bit = type_array[ttv_typ].frst_bit; - num_tbl = type_array[tbl_typ].num_bits; - frst_tbl = type_array[tbl_typ].frst_bit; - tblel_stor = compnt_array[tbl_val].store; - tbldf_stor = compnt_array[tbl_dflt].store; - ttv_stor = compnt_array[trpd_tbl].store; - for (i = 0; i < num_bits; ++i) - if (bitset(src, frst_bit + i)) - for (j = 0; j < num_tbl; ++j) - if (bitset(ttv_stor->types[i], frst_tbl + j)) { - if (chk) { - ChkMrgTyp(n_icntyp, tblel_stor->types[j], dest) - ChkMrgTyp(n_icntyp, tbldf_stor->types[j], dest) - } - else { - MrgTyp(n_icntyp, tblel_stor->types[j], dest) - MrgTyp(n_icntyp, tbldf_stor->types[j], dest) - } - } - - /* - * Aggregate compontents that are variables. - */ - for (i = 0; i < num_cmpnts; ++i) { - if (typecompnt[i].var) { - frst_bit = compnt_array[i].frst_bit; - num_bits = compnt_array[i].num_bits; - store = compnt_array[i].store; - for (j = 0; j < num_bits; ++j) { - if (bitset(src, frst_bit + j)) - if (chk) - ChkMrgTyp(n_icntyp, store->types[j], dest) - else - MrgTyp(n_icntyp, store->types[j], dest) - } - } - } - - - /* - * record fields - */ - for (i = 0; i < n_fld; ++i) - if (bitset(src, frst_fld + i)) { - if (chk) - ChkMrgTyp(n_icntyp, fld_stor->types[i], dest) - else - MrgTyp(n_icntyp, fld_stor->types[i], dest) - } - - /* - * global variables - */ - for (i = 0; i < n_gbl; ++i) - if (bitset(src, frst_gbl + i)) { - if (chk) - ChkMrgTyp(n_icntyp, succ_store->types[i], dest) - else - MrgTyp(n_icntyp, succ_store->types[i], dest) - } - - /* - * local variables - */ - for (i = 0; i < n_loc; ++i) - if (bitset(src, frst_loc + i)) { - if (chk) - ChkMrgTyp(n_icntyp, succ_store->types[n_gbl + i], dest) - else - MrgTyp(n_icntyp, succ_store->types[n_gbl + i], dest) - } -} - -/* - * infer_impl - perform type inference on a call to built-in operation - * using the implementation entry from the data base. - */ -static void infer_impl(impl, n, symtyps, rslt_typ) -struct implement *impl; -nodeptr n; -struct symtyps *symtyps; -#ifdef OptimizeType -struct typinfo *rslt_typ; -#else /* OptimizeType */ -unsigned int *rslt_typ; -#endif /* OptimizeType */ - { -#ifdef OptimizeType - struct typinfo *typ; -#else /* OptimizeType */ - unsigned int *typ; -#endif /* OptimizeType */ - int flag; - int nparms; - int i; - int j; - -#ifdef TypTrc - if (trcfile != NULL) { - fprintf(trcfile, "%s (%d,%d) %s", n->n_file, n->n_line, n->n_col, - trc_indent); - if (impl->oper_typ == 'K') - fprintf(trcfile, "&%s", impl->name); - else - fprintf(trcfile, "%s(", impl->name); - } -#endif /* TypTrc */ - /* - * Set up the "symbol table" of dereferenced and undereferenced - * argument types as needed by the operation. - */ - nparms = impl->nargs; - j = 0; - for (i = 0; i < num_args && i < nparms; ++i) { - if (impl->arg_flgs[i] & RtParm) { - CpyTyp(n_intrtyp, arg_typs->types[i], symtyps->types[j]); - -#ifdef TypTrc - if (trcfile != NULL) { - if (i > 0) - fprintf(trcfile, ", "); - prt_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - ++j; - } - if (impl->arg_flgs[i] & DrfPrm) { - typ_deref(arg_typs->types[i], symtyps->types[j], 0); - -#ifdef TypTrc - if (trcfile != NULL) { - if (impl->arg_flgs[i] & RtParm) - fprintf(trcfile, "->"); - else if (i > 0) - fprintf(trcfile, ", "); - prt_d_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - ++j; - } - } - if (nparms > 0) { - /* - * Check for varargs. Merge remaining arguments into the - * type of the variable part of the parameter list. - */ - flag = impl->arg_flgs[nparms - 1]; - if (flag & VarPrm) { - n_vararg = num_args - nparms + 1; - if (n_vararg < 0) - n_vararg = 0; - typ = symtyps->types[j - 1]; - while (i < num_args) { - if (flag & RtParm) { - MrgTyp(n_intrtyp, arg_typs->types[i], typ) - -#ifdef TypTrc - if (trcfile != NULL) { - if (i > 0) - fprintf(trcfile, ", "); - prt_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - } - else { - typ_deref(arg_typs->types[i], typ, 0); - -#ifdef TypTrc - if (trcfile != NULL) { - if (i > 0) - fprintf(trcfile, ", "); - prt_d_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - } - ++i; - } - nparms -= 1; /* Don't extend with nulls into variable part */ - } - } - while (i < nparms) { - if (impl->arg_flgs[i] & RtParm) - set_typ(symtyps->types[j++], null_bit); /* Extend args with nulls */ - if (impl->arg_flgs[i] & DrfPrm) - set_typ(symtyps->types[j++], null_bit); /* Extend args with nulls */ - ++i; - } - - /* - * If this operation can suspend, there may be backtracking paths - * to this invocation. Merge type information from those paths - * into the current store. - */ - if (impl->ret_flag & DoesSusp) - mrg_store(n->store, succ_store); - - cur_symtyps = symtyps; - cur_rslt.bits = rslt_typ; - cur_rslt.size = n_intrtyp; - cur_new = n->new_types; - infer_il(impl->in_line); /* perform inference on operation */ - - if (MightFail(impl->ret_flag)) - mrg_store(succ_store, fail_store); - -#ifdef TypTrc - if (trcfile != NULL) { - if (impl->oper_typ != 'K') - fprintf(trcfile, ")"); - fprintf(trcfile, " =>> "); - prt_typ(trcfile, rslt_typ); - fprintf(trcfile, "\n"); - } -#endif /* TypTrc */ - } - -/* - * chk_succ - check to see if the operation can succeed. In particular, - * see if it can suspend. Change the succ_store and failure store - * appropriately. - */ -static void chk_succ(ret_flag, susp_stor) -int ret_flag; -struct store *susp_stor; - { - if (ret_flag & DoesSusp) { - if (susp_stor != NULL && (ret_flag & DoesRet)) - mrg_store(susp_stor, fail_store); /* "pass along" failure */ - fail_store = susp_stor; - } - else if (!(ret_flag & DoesRet)) { - free_store(succ_store); - succ_store = get_store(1); - fail_store = dummy_stor; /* shouldn't be used */ - } - } - -/* - * infer_il - perform type inference on a piece of code within built-in - * operation and determine whether execution can get past it. - */ -static int infer_il(il) -struct il_code *il; - { - struct il_code *il1; - int condition; - int case_fnd; - int ncases; - int may_fallthru; - int indx; - int i; - - if (il == NULL) - return 1; - - switch (il->il_type) { - case IL_Const: /* should have been replaced by literal node */ - return 0; - - case IL_If1: - condition = eval_cond(il->u[0].fld); - may_fallthru = (condition & MaybeFalse); - if (condition & MaybeTrue) - may_fallthru |= infer_il(il->u[1].fld); - return may_fallthru; - - case IL_If2: - condition = eval_cond(il->u[0].fld); - may_fallthru = 0; - if (condition & MaybeTrue) - may_fallthru |= infer_il(il->u[1].fld); - if (condition & MaybeFalse) - may_fallthru |= infer_il(il->u[2].fld); - return may_fallthru; - - case IL_Tcase1: - type_case(il, infer_il, NULL); - return 1; /* no point in trying very hard here */ - - case IL_Tcase2: - indx = type_case(il, infer_il, NULL); - if (indx != -1) - infer_il(il->u[indx].fld); /* default */ - return 1; /* no point in trying very hard here */ - - case IL_Lcase: - ncases = il->u[0].n; - indx = 1; - case_fnd = 0; - for (i = 0; i < ncases && !case_fnd; ++i) { - if (il->u[indx++].n == n_vararg) { /* selection number */ - infer_il(il->u[indx].fld); /* action */ - case_fnd = 1; - } - ++indx; - } - if (!case_fnd) - infer_il(il->u[indx].fld); /* default */ - return 1; /* no point in trying very hard here */ - - case IL_Acase: { - int maybe_int; - int maybe_dbl; - - eval_arith((int)il->u[0].fld->u[0].n, (int)il->u[1].fld->u[0].n, - &maybe_int, &maybe_dbl); - if (maybe_int) { - infer_il(il->u[2].fld); /* C_integer action */ - if (largeints) - infer_il(il->u[3].fld); /* integer action */ - } - if (maybe_dbl) - infer_il(il->u[4].fld); /* C_double action */ - return 1; /* no point in trying very hard here */ - } - - case IL_Err1: - case IL_Err2: - return 0; - - case IL_Block: - return il->u[0].n; - - case IL_Call: - return ((il->u[3].n & DoesFThru) != 0); - - case IL_Lst: - if (infer_il(il->u[0].fld)) - return infer_il(il->u[1].fld); - else - return 0; - - case IL_Abstr: - /* - * Handle side effects. - */ - il1 = il->u[0].fld; - if (il1 != NULL) { - while (il1->il_type == IL_Lst) { - side_effect(il1->u[1].fld); - il1 = il1->u[0].fld; - } - side_effect(il1); - } - - /* - * Set return type. - */ - abstr_typ(il->u[1].fld, &cur_rslt); - return 1; - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(EXIT_FAILURE); - /* NOTREACHED */ - } - } - -/* - * side_effect - perform a side effect from an abstract clause of a - * built-in operation. - */ -static void side_effect(il) -struct il_code *il; - { - struct type *var_typ; - struct type *val_typ; - struct store *store; - int num_bits; - int frst_bit; - int i, j; - - /* - * il is IL_TpAsgn, get the variable type and value type, and perform - * the side effect. - */ - var_typ = get_wktyp(); - val_typ = get_wktyp(); - abstr_typ(il->u[0].fld, var_typ); /* variable type */ - abstr_typ(il->u[1].fld, val_typ); /* value type */ - - /* - * Determine which types that can be assigned to are in the variable - * type. - * - * Aggregate compontents. - */ - for (i = 0; i < num_cmpnts; ++i) { - frst_bit = compnt_array[i].frst_bit; - num_bits = compnt_array[i].num_bits; - store = compnt_array[i].store; - for (j = 0; j < num_bits; ++j) { - if (bitset(var_typ->bits, frst_bit + j)) - ChkMrgTyp(n_icntyp, val_typ->bits, store->types[j]) - } - } - - /* - * record fields - */ - for (i = 0; i < n_fld; ++i) - if (bitset(var_typ->bits, frst_fld + i)) - ChkMrgTyp(n_icntyp, val_typ->bits, fld_stor->types[i]); - - /* - * global variables - */ - for (i = 0; i < n_gbl; ++i) - if (bitset(var_typ->bits, frst_gbl + i)) - MrgTyp(n_icntyp, val_typ->bits, succ_store->types[i]); - - /* - * local variables - */ - for (i = 0; i < n_loc; ++i) - if (bitset(var_typ->bits, frst_loc + i)) - MrgTyp(n_icntyp, val_typ->bits, succ_store->types[n_gbl + i]); - - - free_wktyp(var_typ); - free_wktyp(val_typ); - } - -/* - * abstr_typ - compute the type bits corresponding to an abstract type - * from an abstract clause of a built-in operation. - */ -static void abstr_typ(il, typ) -struct il_code *il; -struct type *typ; - { - struct type *typ1; - struct type *typ2; - struct rentry *rec; - struct store *store; - struct compnt_info *compnts; - int num_bits; - int frst_bit; - int frst_cmpnt; - int num_comps; - int typcd; - int new_indx; - int i; - int j; - int indx; - int size; - int t_indx; -#ifdef OptimizeType - struct typinfo *prmtyp; -#else /* OptimizeType */ - unsigned int *prmtyp; -#endif /* OptimizeType */ - - if (il == NULL) - return; - - switch (il->il_type) { - case IL_VarTyp: - /* - * type(<parameter>) - */ - indx = il->u[0].fld->u[0].n; /* symbol table index of variable */ - if (indx >= cur_symtyps->nsyms) { - prmtyp = any_typ; - size = n_rttyp; - } - else { - prmtyp = cur_symtyps->types[indx]; - size = n_intrtyp; - } - if (typ->size < size) - size = typ->size; - MrgTyp(size, prmtyp, typ->bits); - break; - - case IL_Store: - /* - * store[<type>] - */ - typ1 = get_wktyp(); - abstr_typ(il->u[0].fld, typ1); /* type to be "dereferenced" */ - - /* - * Dereference types that are Icon varaibles. - */ - typ_deref(typ1->bits, typ->bits, 0); - - /* - * "Dereference" aggregate compontents that are not Icon variables. - */ - for (i = 0; i < num_cmpnts; ++i) { - if (!typecompnt[i].var) { - if (i == stv_typ) { - /* - * Substring trapped variable stores contain variable - * references, so the types are larger, but we cannot - * copy more than the destination holds. - */ - size = n_intrtyp; - if (typ->size < size) - size = typ->size; - } - else - size = n_icntyp; - frst_bit = compnt_array[i].frst_bit; - num_bits = compnt_array[i].num_bits; - store = compnt_array[i].store; - for (j = 0; j < num_bits; ++j) { - if (bitset(typ1->bits, frst_bit + j)) - MrgTyp(size, store->types[j], typ->bits); - } - } - } - - free_wktyp(typ1); - break; - - case IL_Compnt: - /* - * <type>.<component> - */ - typ1 = get_wktyp(); - abstr_typ(il->u[0].fld, typ1); /* type */ - i = il->u[1].n; - if (i == CM_Fields) { - /* - * The all_fields component must be handled differently - * from the others. - */ - frst_bit = type_array[rec_typ].frst_bit; - num_bits = type_array[rec_typ].num_bits; - for (i = 0; i < num_bits; ++i) - if (bitset(typ1->bits, frst_bit + i)) { - rec = rec_map[i]; - for (j = 0; j < rec->nfields; ++j) - set_typ(typ->bits, frst_fld + rec->frst_fld + j); - } - } - else { - /* - * Use component information arrays to transform type bits to - * the corresponding component bits. - */ - frst_bit = type_array[typecompnt[i].aggregate].frst_bit; - num_bits = type_array[typecompnt[i].aggregate].num_bits; - frst_cmpnt = compnt_array[i].frst_bit; - if (!typecompnt[i].var && typ->size < n_rttyp) - break; /* bad abstract type computation */ - for (i = 0; i < num_bits; ++i) - if (bitset(typ1->bits, frst_bit + i)) - set_typ(typ->bits, frst_cmpnt + i); - free_wktyp(typ1); - } - break; - - case IL_Union: - /* - * <type 1> ++ <type 2> - */ - abstr_typ(il->u[0].fld, typ); - abstr_typ(il->u[1].fld, typ); - break; - - case IL_Inter: - /* - * <type 1> ** <type 2> - */ - typ1 = get_wktyp(); - typ2 = get_wktyp(); - abstr_typ(il->u[0].fld, typ1); - abstr_typ(il->u[1].fld, typ2); - size = n_rttyp; -#ifdef OptimizeType - and_bits_to_packed(typ2->bits, typ1->bits, size); -#else /* OptimizeType */ - for (i = 0; i < NumInts(size); ++i) - typ1->bits[i] &= typ2->bits[i]; -#endif /* OptimizeType */ - if (typ->size < size) - size = typ->size; - MrgTyp(size, typ1->bits, typ->bits); - free_wktyp(typ1); - free_wktyp(typ2); - break; - - case IL_New: - /* - * new <type-name>(<type 1> , ...) - * - * If a type was not allocated for this node, use the default - * one. - */ - typ1 = get_wktyp(); - typcd = il->u[0].n; /* type code */ - new_indx = type_array[typcd].new_indx; - t_indx = 0; /* default is first index of type */ - if (cur_new != NULL && cur_new[new_indx] > 0) - t_indx = cur_new[new_indx]; - - /* - * This RTL expression evaluates to the "new" sub-type. - */ - set_typ(typ->bits, type_array[typcd].frst_bit + t_indx); - - /* - * Update stores for components based on argument types in the - * "new" expression. - */ - num_comps = icontypes[typcd].num_comps; - j = icontypes[typcd].compnts; - compnts = &compnt_array[j]; - if (typcd == stv_typ) { - size = n_intrtyp; - } - else - size = n_icntyp; - for (i = 0; i < num_comps; ++i) { - ClrTyp(n_rttyp, typ1->bits); - abstr_typ(il->u[2 + i].fld, typ1); - ChkMrgTyp(size, typ1->bits, compnts[i].store->types[t_indx]); - } - - free_wktyp(typ1); - break; - - case IL_IcnTyp: - typcd_bits((int)il->u[0].n, typ); /* type code */ - break; - } - } - -/* - * eval_cond - evaluate the condition of in 'if' statement from a - * built-in operation. The result can be both true and false because - * of uncertainty and because more than one execution path may be - * involved. - */ -static int eval_cond(il) -struct il_code *il; - { - int cond1; - int cond2; - - switch (il->il_type) { - case IL_Bang: - cond1 = eval_cond(il->u[0].fld); - cond2 = 0; - if (cond1 & MaybeTrue) - cond2 = MaybeFalse; - if (cond1 & MaybeFalse) - cond2 |= MaybeTrue; - return cond2; - - case IL_And: - cond1 = eval_cond(il->u[0].fld); - cond2 = eval_cond(il->u[1].fld); - return (cond1 & cond2 & MaybeTrue) | ((cond1 | cond2) & MaybeFalse); - - case IL_Cnv1: - case IL_Cnv2: - return eval_cnv((int)il->u[0].n, (int)il->u[1].fld->u[0].n, - 0, NULL); - - case IL_Def1: - case IL_Def2: - return eval_cnv((int)il->u[0].n, (int)il->u[1].fld->u[0].n, - 1, NULL); - - case IL_Is: - return eval_is((int)il->u[0].n, il->u[1].fld->u[0].n); - - default: - fprintf(stderr, "compiler error: unknown info in data base\n"); - exit(EXIT_FAILURE); - /* NOTREACHED */ - } - } - -/* - * eval_cnv - evaluate the conversion of a variable to a specific type - * to see if it may succeed or fail. - */ -int eval_cnv(typcd, indx, def, cnv_flags) -int typcd; /* type to convert to */ -int indx; /* index into symbol table of variable */ -int def; /* flag: conversion has a default value */ -int *cnv_flags; /* return flag for detailed conversion information */ - { - struct type *may_succeed; /* types where conversion sometimes succeed */ - struct type *must_succeed; /* types where conversion always succeeds */ - struct type *must_cnv; /* types where actual conversion is performed */ - struct type *as_is; /* types where value already has correct type */ -#ifdef OptimizeType - struct typinfo *typ; /* possible types of the variable */ -#else /* OptimizeType */ - unsigned int *typ; -#endif /* OptimizeType */ - int cond; - int i; -#ifdef OptimizeType - unsigned int val1, val2; -#endif /* OptimizeType */ - - /* - * Conversions may succeed for strings, integers, csets, and reals. - * Conversions may fail for any other types. In addition, - * conversions to integer or real may fail for specific values. - */ - if (indx >= cur_symtyps->nsyms) - return MaybeTrue | MaybeFalse; - typ = cur_symtyps->types[indx]; - - may_succeed = get_wktyp(); - must_succeed = get_wktyp(); - must_cnv = get_wktyp(); - as_is = get_wktyp(); - - if (typcd == cset_typ || typcd == TypTCset) { - set_typ(as_is->bits, cset_bit); - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, int_bit); - set_typ(must_cnv->bits, real_bit); - - set_typ(must_succeed->bits, str_bit); - set_typ(must_succeed->bits, cset_bit); - set_typ(must_succeed->bits, int_bit); - set_typ(must_succeed->bits, real_bit); - } - else if (typcd == str_typ || typcd == TypTStr) { - set_typ(as_is->bits, str_bit); - - set_typ(must_cnv->bits, cset_bit); - set_typ(must_cnv->bits, int_bit); - set_typ(must_cnv->bits, real_bit); - - set_typ(must_succeed->bits, str_bit); - set_typ(must_succeed->bits, cset_bit); - set_typ(must_succeed->bits, int_bit); - set_typ(must_succeed->bits, real_bit); - } - else if (typcd == TypCStr) { - /* - * as_is is empty. - */ - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, cset_bit); - set_typ(must_cnv->bits, int_bit); - set_typ(must_cnv->bits, real_bit); - - set_typ(must_succeed->bits, str_bit); - set_typ(must_succeed->bits, cset_bit); - set_typ(must_succeed->bits, int_bit); - set_typ(must_succeed->bits, real_bit); - } - else if (typcd == real_typ) { - set_typ(as_is->bits, real_bit); - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, cset_bit); - set_typ(must_cnv->bits, int_bit); - - set_typ(must_succeed->bits, int_bit); - set_typ(must_succeed->bits, real_bit); - } - else if (typcd == TypCDbl) { - /* - * as_is is empty. - */ - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, cset_bit); - set_typ(must_cnv->bits, int_bit); - set_typ(must_cnv->bits, real_bit); - - set_typ(must_succeed->bits, int_bit); - set_typ(must_succeed->bits, real_bit); - } - else if (typcd == int_typ) { - set_typ(as_is->bits, int_bit); - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, cset_bit); - set_typ(must_cnv->bits, real_bit); - - set_typ(must_succeed->bits, int_bit); - } - else if (typcd == TypCInt) { - /* - * Note that conversion from an integer to a C integer can be - * done by changing the way the descriptor is accessed. It - * is not considered a real conversion. Conversion may fail - * even for integers if large integers are supported. - */ - set_typ(as_is->bits, int_bit); - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, cset_bit); - set_typ(must_cnv->bits, real_bit); - - if (!largeints) - set_typ(must_succeed->bits, int_bit); - } - else if (typcd == TypEInt) { - set_typ(as_is->bits, int_bit); - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, cset_bit); - - set_typ(must_succeed->bits, int_bit); - } - else if (typcd == TypECInt) { - set_typ(as_is->bits, int_bit); - - set_typ(must_cnv->bits, str_bit); - set_typ(must_cnv->bits, cset_bit); - - if (!largeints) - set_typ(must_succeed->bits, int_bit); - } - - MrgTyp(n_icntyp, as_is->bits, may_succeed->bits); - MrgTyp(n_icntyp, must_cnv->bits, may_succeed->bits); - if (def) { - set_typ(may_succeed->bits, null_bit); - set_typ(must_succeed->bits, null_bit); - } - - /* - * Determine if the conversion expression may evaluate to true or false. - */ - cond = 0; - -/* - if (typ->bits == NULL) { - typ->bits = alloc_mem_typ(typ->size); - xfer_packed_types(typ); - } - if (may_succeed->bits->bits == NULL) { - may_succeed->bits->bits = alloc_mem_typ(may_succeed->bits->size); - xfer_packed_types(may_succeed->bits); - } - if (must_succeed->bits->bits == NULL) { - must_succeed->bits->bits = alloc_mem_typ(must_succeed->bits->size); - xfer_packed_types(must_succeed->bits); - } -*/ - for (i = 0; i < NumInts(n_intrtyp); ++i) { -#ifdef OptimizeType - if ((typ->bits != NULL) && (may_succeed->bits->bits != NULL)) { - if (typ->bits[i] & may_succeed->bits->bits[i]) - cond = MaybeTrue; - } - else if ((typ->bits == NULL) && (may_succeed->bits->bits != NULL)) { - val1 = get_bit_vector(typ, i); - if (val1 & may_succeed->bits->bits[i]) - cond = MaybeTrue; - } - else if ((typ->bits != NULL) && (may_succeed->bits->bits == NULL)) { - val2 = get_bit_vector(may_succeed->bits, i); - if (typ->bits[i] & val2) - cond = MaybeTrue; - } - else { - val1 = get_bit_vector(typ, i); - val2 = get_bit_vector(may_succeed->bits, i); - if (val1 & val2) - cond = MaybeTrue; - } - if ((typ->bits != NULL) && (must_succeed->bits->bits != NULL)) { - if (typ->bits[i] & ~must_succeed->bits->bits[i]) - cond |= MaybeFalse; - } - else if ((typ->bits == NULL) && (must_succeed->bits->bits != NULL)) { - val1 = get_bit_vector(typ, i); - if (val1 & ~must_succeed->bits->bits[i]) - cond |= MaybeFalse; - } - else if ((typ->bits != NULL) && (must_succeed->bits->bits == NULL)) { - val2 = get_bit_vector(must_succeed->bits, i); - if (typ->bits[i] & ~val2) - cond |= MaybeFalse; - } - else { - val1 = get_bit_vector(typ, i); - val2 = get_bit_vector(must_succeed->bits, i); - if (val1 & ~val2) - cond |= MaybeFalse; - } -#else /* OptimizeType */ - if (typ[i] & may_succeed->bits[i]) - cond = MaybeTrue; - if (typ[i] & ~must_succeed->bits[i]) - cond |= MaybeFalse; -#endif /* OptimizeType */ - } - - /* - * See if more detailed information about the conversion is needed. - */ - if (cnv_flags != NULL) { - *cnv_flags = 0; -/* - if (as_is->bits == NULL) { - as_is->bits->bits = alloc_mem_typ(as_is->bits->size); - xfer_packed_types(as_is->bits); - } - if (must_cnv->bits->bits == NULL) { - must_cnv->bits->bits = alloc_mem_typ(must_cnv->bits->size); - xfer_packed_types(must_cnv->bits); - } -*/ - for (i = 0; i < NumInts(n_intrtyp); ++i) { -#ifdef OptimizeType - if ((typ->bits != NULL) && (as_is->bits->bits != NULL)) { - if (typ->bits[i] & as_is->bits->bits[i]) - *cnv_flags |= MayKeep; - } - else if ((typ->bits == NULL) && (as_is->bits->bits != NULL)) { - val1 = get_bit_vector(typ, i); - if (val1 & as_is->bits->bits[i]) - *cnv_flags |= MayKeep; - } - else if ((typ->bits != NULL) && (as_is->bits->bits == NULL)) { - val2 = get_bit_vector(as_is->bits, i); - if (typ->bits[i] & val2) - *cnv_flags |= MayKeep; - } - else { - val1 = get_bit_vector(typ, i); - val2 = get_bit_vector(as_is->bits, i); - if (val1 & val2) - *cnv_flags |= MayKeep; - } - if ((typ->bits != NULL) && (must_cnv->bits->bits != NULL)) { - if (typ->bits[i] & must_cnv->bits->bits[i]) - *cnv_flags |= MayConvert; - } - else if ((typ->bits == NULL) && (must_cnv->bits->bits != NULL)) { - val1 = get_bit_vector(typ, i); - if (val1 & must_cnv->bits->bits[i]) - *cnv_flags |= MayConvert; - } - else if ((typ->bits != NULL) && (must_cnv->bits->bits == NULL)) { - val2 = get_bit_vector(must_cnv->bits, i); - if (typ->bits[i] & val2) - *cnv_flags |= MayConvert; - } - else { - val1 = get_bit_vector(typ, i); - val2 = get_bit_vector(must_cnv->bits, i); - if (val1 & val2) - *cnv_flags |= MayConvert; - } -#else /* OptimizeType */ - if (typ[i] & as_is->bits[i]) - *cnv_flags |= MayKeep; - if (typ[i] & must_cnv->bits[i]) - *cnv_flags |= MayConvert; -#endif /* OptimizeType */ - } - if (def && bitset(typ, null_bit)) - *cnv_flags |= MayDefault; - } - - free_wktyp(may_succeed); - free_wktyp(must_succeed); - free_wktyp(must_cnv); - free_wktyp(as_is); - - return cond; - } - -/* - * eval_is - evaluate the result of an 'is' expression within a built-in - * operation. - */ -int eval_is(typcd, indx) -int typcd; -int indx; - { - int cond; -#ifdef OptimizeType - struct typinfo *typ; -#else /* OptimizeType */ - unsigned int *typ; -#endif /* OptimizeType */ - - if (indx >= cur_symtyps->nsyms) - return MaybeTrue | MaybeFalse; - typ = cur_symtyps->types[indx]; - if (has_type(typ, typcd, 0)) - cond = MaybeTrue; - else - cond = 0; - if (other_type(typ, typcd)) - cond |= MaybeFalse; - return cond; - } - -/* - * eval_arith - determine which cases of an arith_case may be taken based - * on the types of its arguments. - */ -void eval_arith(indx1, indx2, maybe_int, maybe_dbl) -int indx1; -int indx2; -int *maybe_int; -int *maybe_dbl; - { -#ifdef OptimizeType - struct typinfo *typ1; /* possible types of first variable */ - struct typinfo *typ2; /* possible types of second variable */ -#else /* OptimizeType */ - unsigned int *typ1; /* possible types of first variable */ - unsigned int *typ2; /* possible types of second variable */ -#endif /* OptimizeType */ - int int1 = 0; - int int2 = 0; - int dbl1 = 0; - int dbl2 = 0; - - typ1 = cur_symtyps->types[indx1]; - typ2 = cur_symtyps->types[indx2]; - - /* - * First see what might result if you do a convert to numeric on each - * variable. - */ - if (bitset(typ1, int_bit)) - int1 = 1; - if (bitset(typ1, real_bit)) - dbl1 = 1; - if (bitset(typ1, str_bit) || bitset(typ1, cset_bit)) { - int1 = 1; - dbl1 = 1; - } - if (bitset(typ2, int_bit)) - int2 = 1; - if (bitset(typ2, real_bit)) - dbl2 = 1; - if (bitset(typ2, str_bit) || bitset(typ2, cset_bit)) { - int2 = 1; - dbl2 = 1; - } - - /* - * Use the conversion information to figure out what type of arithmetic - * might be done. - */ - if (int1 && int2) - *maybe_int = 1; - else - *maybe_int = 0; - - *maybe_dbl = 0; - if (dbl1 && dbl2) - *maybe_dbl = 1; - else if (dbl1 && int2) - *maybe_dbl = 1; - else if (int1 && dbl2) - *maybe_dbl = 1; - } - -/* - * type_case - Determine which cases are selected in a type_case - * statement. This routine is used by both type inference and - * the code generator: a different fnc is passed in each case. - * In addition, the code generator passes a case_anlz structure. - */ -int type_case(il, fnc, case_anlz) -struct il_code *il; -int (*fnc)(); -struct case_anlz *case_anlz; - { - int *typ_vect; - int i, j; - int num_cases; - int num_types; - int indx; - int sym_indx; - int typcd; - int use_dflt; -#ifdef OptimizeType - struct typinfo *typ; -#else /* OptimizeType */ - unsigned int *typ; -#endif /* OptimizeType */ - int select; - struct type *wktyp; - - /* - * Make a copy of the type of the variable the type case is - * working on. - */ - sym_indx = il->u[0].fld->u[0].n; /* symbol table index */ - if (sym_indx >= cur_symtyps->nsyms) - typ = any_typ; /* variable is not a parameter, don't know type */ - else - typ = cur_symtyps->types[sym_indx]; - wktyp = get_wktyp(); - CpyTyp(n_intrtyp, typ, wktyp->bits); - typ = wktyp->bits; - - /* - * Loop through all the case clauses. - */ - num_cases = il->u[1].n; - indx = 2; - for (i = 0; i < num_cases; ++i) { - /* - * For each of the types selected by this clause, see if the variable's - * type bit vector contains that type and delete the type from the - * bit vector (so we know if we need the default when we are done). - */ - num_types = il->u[indx++].n; - typ_vect = il->u[indx++].vect; - select = 0; - for (j = 0; j < num_types; ++j) - if (has_type(typ, typ_vect[j], 1)) { - typcd = typ_vect[j]; - select += 1; - } - - if (select > 0) { - fnc(il->u[indx].fld); /* action */ - - /* - * If this routine was called by the code generator, we need to - * return extra information. - */ - if (case_anlz != NULL) { - ++case_anlz->n_cases; - if (select == 1) { - if (case_anlz->il_then == NULL) { - case_anlz->typcd = typcd; - case_anlz->il_then = il->u[indx].fld; - } - else if (case_anlz->il_else == NULL) - case_anlz->il_else = il->u[indx].fld; - } - else { - /* - * There is more than one possible type that will cause - * us to select this case. It can only be used in the "else". - */ - if (case_anlz->il_else == NULL) - case_anlz->il_else = il->u[indx].fld; - else - case_anlz->n_cases = 3; /* force no inlining. */ - } - } - } - ++indx; - } - - /* - * If there are types that have not been handled, indicate this by - * returning the index of the default clause. - */ - use_dflt = 0; - for (i = 0; i < n_intrtyp; ++i) - if (bitset(typ, i)) { - use_dflt = 1; - break; - } - free_wktyp(wktyp); - if (use_dflt) - return indx; - else - return -1; - } - -/* - * gen_inv - general invocation. The argument list is set up, perform - * abstract interpretation on each possible things being invoked. - */ -static void gen_inv(typ, n) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -nodeptr n; - { - int ret_flag = 0; - struct store *s_store; - struct store *store; - struct gentry *gptr; - struct implement *ip; - struct type *prc_typ; - int frst_prc; - int num_prcs; - int i; - -#ifdef TypTrc - if (trcfile != NULL) { - fprintf(trcfile, "%s (%d,%d) {\n", n->n_file, n->n_line, n->n_col); - trc_indent = " "; - } -#endif /* TypTrc */ - - frst_prc = type_array[proc_typ].frst_bit; - num_prcs = type_array[proc_typ].num_bits; - - /* - * Dereference the type of the thing being invoked. - */ - prc_typ = get_wktyp(); - typ_deref(typ, prc_typ->bits, 0); - - s_store = succ_store; - store = get_store(1); - - if (bitset(prc_typ->bits, str_bit) || - bitset(prc_typ->bits, cset_bit) || - bitset(prc_typ->bits, int_bit) || - bitset(prc_typ->bits, real_bit)) { - /* - * Assume integer invocation; any argument may be the result type. - */ - -#ifdef TypTrc - if (trcfile != NULL) { - fprintf(trcfile, "%s (%d,%d) %s{i}(", n->n_file, n->n_line, n->n_col, - trc_indent); - } -#endif /* TypTrc */ - - for (i = 0; i < num_args; ++i) { - MrgTyp(n_intrtyp, arg_typs->types[i], n->type); - -#ifdef TypTrc - if (trcfile != NULL) { - if (i > 0) - fprintf(trcfile, ", "); - prt_typ(trcfile, arg_typs->types[i]); - } -#endif /* TypTrc */ - - } - - /* - * Integer invocation may succeed or fail. - */ - ret_flag |= DoesRet | DoesFail; - mrg_store(s_store, store); - mrg_store(s_store, fail_store); - -#ifdef TypTrc - if (trcfile != NULL) { - fprintf(trcfile, ") =>> "); - prt_typ(trcfile, n->type); - fprintf(trcfile, "\n"); - } -#endif /* TypTrc */ - } - - if (bitset(prc_typ->bits, str_bit) || - bitset(prc_typ->bits, cset_bit)) { - /* - * Assume string invocation; add all procedure types to the thing - * being invoked. - */ - for (i = 0; i < num_prcs; ++i) - set_typ(prc_typ->bits, frst_prc + i); - } - - if (bitset(prc_typ->bits, frst_prc)) { - /* - * First procedure type represents all operators that are - * available via string invocation. Scan the operator table - * looking for those that are in the string invocation table. - * Note, this is not particularly efficient or precise. - */ - for (i = 0; i < IHSize; ++i) - for (ip = ohash[i]; ip != NULL; ip = ip->blink) - if (ip->iconc_flgs & InStrTbl) { - succ_store = cpy_store(s_store); - infer_impl(ip, n, n->symtyps, n->type); - ret_flag |= ip->ret_flag; - mrg_store(succ_store, store); - free_store(succ_store); - } - } - - /* - * Check for procedure, built-in, and record constructor types - * and perform type inference on invocations of them. - */ - for (i = 1; i < num_prcs; ++i) - if (bitset(prc_typ->bits, frst_prc + i)) { - succ_store = cpy_store(s_store); - gptr = proc_map[i]; - switch (gptr->flag & (F_Proc | F_Builtin | F_Record)) { - case F_Proc: - infer_prc(gptr->val.proc, n); - ret_flag |= gptr->val.proc->ret_flag; - break; - case F_Builtin: - infer_impl(gptr->val.builtin, n, n->symtyps, n->type); - ret_flag |= gptr->val.builtin->ret_flag; - break; - case F_Record: - infer_con(gptr->val.rec, n); - ret_flag |= DoesRet | (err_conv ? DoesFail : 0); - break; - } - mrg_store(succ_store, store); - free_store(succ_store); - } - - /* - * If error conversion is supported and a non-procedure value - * might be invoked, assume the invocation can fail. - */ - if (err_conv && other_type(prc_typ->bits, proc_typ)) - mrg_store(s_store, fail_store); - - free_store(s_store); - succ_store = store; - chk_succ(ret_flag, n->store); - - free_wktyp(prc_typ); - -#ifdef TypTrc - if (trcfile != NULL) { - fprintf(trcfile, "%s (%d,%d) }\n", n->n_file, n->n_line, n->n_col); - trc_indent = ""; - } -#endif /* TypTrc */ - } - -/* - * get_wktyp - get a dynamically allocated bit vector to use as a - * work area for doing type computations. - */ -static struct type *get_wktyp() - { - struct type *typ; - - if ((typ = type_pool) == NULL) { - typ = NewStruct(type); - typ->size = n_rttyp; - typ->bits = alloc_typ(n_rttyp); - } - else { - type_pool = type_pool->next; - ClrTyp(n_rttyp, typ->bits); - } - return typ; - } - -/* - * free_wktyp - free a dynamically allocated type bit vector. - */ -static void free_wktyp(typ) -struct type *typ; - { - typ->next = type_pool; - type_pool = typ; - } - -#ifdef TypTrc - -/* - * ChkSep - supply a separating space if this is not the first item. - */ -#define ChkSep(n) (++n > 1 ? " " : "") - -/* - * prt_typ - print a type that can include variable references. - */ -static void prt_typ(file, typ) -FILE *file; -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ - { - struct gentry *gptr; - struct lentry *lptr; - char *name; - int i, j, k; - int n; - int frst_bit; - int num_bits; - char *abrv; - - fprintf(trcfile, "{"); - n = 0; - /* - * Go through the types and see any sub-types are present. - */ - for (k = 0; k < num_typs; ++k) { - frst_bit = type_array[k].frst_bit; - num_bits = type_array[k].num_bits; - abrv = icontypes[k].abrv; - if (k == proc_typ) { - /* - * procedures, record constructors, and built-in functions. - */ - for (i = 0; i < num_bits; ++i) - if (bitset(typ, frst_bit + i)) { - if (i == 0) - fprintf(file, "%sops", ChkSep(n)); - else { - gptr = proc_map[i]; - switch (gptr->flag & (F_Proc | F_Builtin | F_Record)) { - case F_Proc: - fprintf(file, "%s%s:%s", ChkSep(n), abrv, gptr->name); - break; - case F_Builtin: - fprintf(file, "%sfnc:%s", ChkSep(n), gptr->name); - break; - case F_Record: - fprintf(file, "%sconstr:%s", ChkSep(n), gptr->name); - break; - } - } - } - } - else if (k == rec_typ) { - /* - * records - include record name. - */ - for (i = 0; i < num_bits; ++i) - if (bitset(typ, frst_bit + i)) - fprintf(file, "%s%s:%s", ChkSep(n), abrv, rec_map[i]->name); - } - else if (icontypes[k].support_new | k == coexp_typ) { - /* - * A type with sub-types. - */ - for (i = 0; i < num_bits; ++i) - if (bitset(typ, frst_bit + i)) - fprintf(file, "%s%s%d", ChkSep(n), abrv, i); - } - else { - /* - * A type with no subtypes. - */ - if (bitset(typ, frst_bit)) - fprintf(file, "%s%s", ChkSep(n), abrv); - } - } - - for (k = 0; k < num_cmpnts; ++k) { - if (typecompnt[k].var) { - /* - * Structure component that is a variable. - */ - frst_bit = compnt_array[k].frst_bit; - num_bits = compnt_array[k].num_bits; - abrv = typecompnt[k].abrv; - for (i = 0; i < num_bits; ++i) - if (bitset(typ, frst_bit + i)) - fprintf(file, "%s%s%d", ChkSep(n), abrv, i); - } - } - - - /* - * record fields - */ - for (i = 0; i < n_fld; ++i) - if (bitset(typ, frst_fld + i)) - fprintf(file, "%sfld%d", ChkSep(n), i); - - /* - * global variables - */ - for (i = 0; i < n_nmgbl; ++i) - if (bitset(typ, frst_gbl + i)) { - name = NULL; - for (j = 0; j < GHSize && name == NULL; j++) - for (gptr = ghash[j]; gptr != NULL && name == NULL; - gptr = gptr->blink) - if (gptr->index == i) - name = gptr->name; - for (lptr = cur_proc->statics; lptr != NULL && name == NULL; - lptr = lptr->next) - if (lptr->val.index == i) - name = lptr->name; - /* - * Static variables may be returned and dereferenced in a procedure - * they don't belong to. - */ - if (name == NULL) - name = "?static?"; - fprintf(file, "%svar:%s", ChkSep(n), name); - } - - /* - * local variables - */ - for (i = 0; i < n_loc; ++i) - if (bitset(typ, frst_loc + i)) { - name = NULL; - for (lptr = cur_proc->args; lptr != NULL && name == NULL; - lptr = lptr->next) - if (lptr->val.index == i) - name = lptr->name; - for (lptr = cur_proc->dynams; lptr != NULL && name == NULL; - lptr = lptr->next) - if (lptr->val.index == i) - name = lptr->name; - /* - * Local variables types may appear in the wrong procedure due to - * substring trapped variables and the inference of impossible - * execution paths. Make sure we don't end up with a NULL name. - */ - if (name == NULL) - name = "?"; - fprintf(file, "%svar:%s", ChkSep(n), name); - } - - fprintf(trcfile, "}"); - } - -/* - * prt_d_typ - dereference a type and print it. - */ -static void prt_d_typ(file, typ) -FILE *file; -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -{ - struct type *wktyp; - - wktyp = get_wktyp(); - typ_deref(typ, wktyp->bits, 0); - prt_typ(file, wktyp->bits); - free_wktyp(wktyp); -} -#endif /* TypTrc */ - -/* - * get_argtyp - get an array of pointers to type bit vectors for use - * in constructing an argument list. The array is large enough for the - * largest argument list. - */ -static struct argtyps *get_argtyp() - { - struct argtyps *argtyps; - - if ((argtyps = argtyp_pool) == NULL) -#ifdef OptimizeType - argtyps = (struct argtyps *)alloc((unsigned int)(sizeof(struct argtyps) + - ((max_prm - 1) * sizeof(struct typinfo *)))); -#else /* OptimizeType */ - argtyps = (struct argtyps *)alloc((unsigned int)(sizeof(struct argtyps) + - ((max_prm - 1) * sizeof(unsigned int *)))); -#endif /* OptimizeType */ - else - argtyp_pool = argtyp_pool->next; - return argtyps; - } - -/* - * free_argtyp - free array of pointers to type bitvectors. - */ -static void free_argtyp(argtyps) -struct argtyps *argtyps; - { - argtyps->next = argtyp_pool; - argtyp_pool = argtyps; - } - -/* - * varsubtyp - examine a type and determine what kinds of variable - * subtypes it has and whether it has any non-variable subtypes. - * If the type consists of a single named variable, return its symbol - * table entry through the parameter "singl". - */ -int varsubtyp(typ, singl) -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -struct lentry **singl; - { - struct store *stv_stor; - int subtypes; - int n_types; - int var_indx; - int frst_bit; - int num_bits; - int i, j; - - - subtypes = 0; - n_types = 0; - var_indx = -1; - - /* - * check for non-variables. - */ - for (i = 0; i < n_icntyp; ++i) - if (bitset(typ, i)) { - subtypes |= HasVal; - ++n_types; - } - - /* - * Predefined variable types. - */ - for (i = 0; i < num_typs; ++i) { - if (icontypes[i].deref != DrfNone) { - frst_bit = type_array[i].frst_bit; - num_bits = type_array[i].num_bits; - for (j = 0; j < num_bits; ++j) { - if (bitset(typ, frst_bit + j)) { - if (i == stv_typ) { - /* - * We have found substring trapped variable j, see whether it - * references locals or globals. - */ - if (do_typinfer) { - stv_stor = compnt_array[str_var].store; - subtypes |= varsubtyp(stv_stor->types[j], NULL); - } - else - subtypes |= HasLcl | HasPrm | HasGlb; - } - else - subtypes |= HasGlb; - ++n_types; - } - } - } - } - - /* - * Aggregate compontents that are variables. - */ - for (i = 0; i < num_cmpnts; ++i) { - if (typecompnt[i].var) { - frst_bit = compnt_array[i].frst_bit; - num_bits = compnt_array[i].num_bits; - for (j = 0; j < num_bits; ++j) { - if (bitset(typ, frst_bit + j)) { - subtypes |= HasGlb; - ++n_types; - } - } - } - } - - /* - * record fields - */ - for (i = 0; i < n_fld; ++i) - if (bitset(typ, frst_fld + i)) { - subtypes |= HasGlb; - ++n_types; - } - - /* - * global variables, including statics - */ - for (i = 0; i < n_gbl; ++i) { - if (bitset(typ, frst_gbl + i)) { - subtypes |= HasGlb; - var_indx = i; - ++n_types; - } - } - - /* - * local variables - */ - for (i = 0; i < n_loc; ++i) { - if (bitset(typ, frst_loc + i)) { - if (i < Abs(cur_proc->nargs)) - subtypes |= HasPrm; - else - subtypes |= HasLcl; - var_indx = n_gbl + i; - ++n_types; - } - } - - if (singl != NULL) { - /* - * See if the type consists of a single named variable. - */ - if (n_types == 1 && var_indx != -1) - *singl = cur_proc->vartypmap[var_indx]; - else - *singl = NULL; - } - - return subtypes; - } - -/* - * mark_recs - go through the list of parent records for this field - * and mark those that are in the type. Also gather information - * to help generate better code. - */ -void mark_recs(fp, typ, num_offsets, offset, bad_recs) -struct fentry *fp; -#ifdef OptimizeType -struct typinfo *typ; -#else /* OptimizeType */ -unsigned int *typ; -#endif /* OptimizeType */ -int *num_offsets; -int *offset; -int *bad_recs; - { - struct par_rec *rp; - struct type *wktyp; - int frst_rec; - - *num_offsets = 0; - *offset = -1; - *bad_recs = 0; - - wktyp = get_wktyp(); - CpyTyp(n_icntyp, typ, wktyp->bits); - - /* - * For each record containing this field, see if the record is - * in the type. - */ - frst_rec = type_array[rec_typ].frst_bit; - for (rp = fp->rlist; rp != NULL; rp = rp->next) { - if (bitset(wktyp->bits, frst_rec + rp->rec->rec_num)) { - /* - * This record is in the type. - */ - rp->mark = 1; - clr_typ(wktyp->bits, frst_rec + rp->rec->rec_num); - if (*offset != rp->offset) { - *offset = rp->offset; - *num_offsets += 1; - } - } - } - - /* - * Are there any records that do not contain this field? - */ - *bad_recs = has_type(wktyp->bits, rec_typ, 0); - free_wktyp(wktyp); - } - -/* - * past_prms - return true if execution might continue past the parameter - * evaluation. If a parameter has no type, this will not happen. - */ -int past_prms(n) -nodeptr n; - { - struct implement *impl; - struct symtyps *symtyps; - int nparms; - int nargs; - int flag; - int i, j; - - nargs = Val0(n); - impl = Impl1(n); - symtyps = n->symtyps; - nparms = impl->nargs; - - if (symtyps == NULL) - return 1; - - j = 0; - for (i = 0; i < nparms; ++i) { - flag = impl->arg_flgs[i]; - if (flag & VarPrm && i >= nargs) - break; /* no parameters for variable part of arg list */ - if (flag & RtParm) { - if (is_empty(symtyps->types[j])) - return 0; - ++j; - } - if (flag & DrfPrm) { - if (is_empty(symtyps->types[j])) - return 0; - ++j; - } - } - return 1; - } diff --git a/src/icont/Makefile b/src/icont/Makefile index 8f15f9d..db0927f 100644 --- a/src/icont/Makefile +++ b/src/icont/Makefile @@ -22,7 +22,7 @@ icont: $(OBJS) $(COBJS) $(CC) $(CFLAGS) $(LDFLAGS) -o icont $(OBJS) $(COBJS) cp icont ../../bin strip ../../bin/icont$(EXE) - (cd ../../bin; rm -f icon; ln -s icont icon) + (cd ../../bin; rm -f icon icon.exe; ln -s icont icon) $(OBJS): $(HFILES) tproto.h @@ -45,7 +45,7 @@ tree.o: tree.h tsym.o: tglobals.h tsym.h ttoken.h lfile.h keyword.h ../h/kdefs.h # linker files -$(LINKR): link.h lfile.h ../h/rt.h ../h/sys.h ../h/monitor.h \ +$(LINKR): link.h lfile.h ../h/rt.h ../h/sys.h \ ../h/rstructs.h ../h/rmacros.h ../h/rexterns.h link.o: tglobals.h hdr.h ../h/header.h diff --git a/src/icont/lcode.c b/src/icont/lcode.c index a1481f1..a1c7a57 100644 --- a/src/icont/lcode.c +++ b/src/icont/lcode.c @@ -38,15 +38,6 @@ static void outblock (char *addr,int count); static void setfile (void); static void wordout (word oword); -#ifdef FieldTableCompression - static void charout (unsigned char oint); - static void shortout (short oint); -#endif /* FieldTableCompression */ - -#ifdef DeBugLinker - static void dumpblock (char *addr,int count); -#endif /* DeBugLinker */ - word pc = 0; /* simulated program counter */ #define outword(n) wordout((word)(n)) @@ -243,71 +234,22 @@ void gencode() case Op_Lab: lab = getlab(); newline(); - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "L%d:\n", lab); - #endif /* DeBugLinker */ backpatch(lab); break; case Op_Line: - /* - * Line number change. - * All the interesting stuff happens in Op_Colm now. - */ lineno = getdec(); - - #ifndef SrcColumnInfo - /* - * Enter the value in the line number table - * that is stored in the icode file and used during error - * handling and execution monitoring. One can generate a VM - * instruction for these changes, but since the numbers are not - * saved and restored during backtracking, it is more accurate - * to check for line number changes in-line in the interpreter. - * Fortunately, the in-line check is about as fast as executing - * Op_Line instructions. All of this is complicated by the use - * of Op_Line to generate Noop instructions when enabled by the - * LineCodes #define. - * - * If SrcColumnInfo is required, this code is duplicated, - * with changes, in the Op_Colm case below. - */ - if (lnfree >= &lntable[nsize]) - lntable = (struct ipc_line *)trealloc(lntable,&lnfree,&nsize, - sizeof(struct ipc_line), 1, "line number table"); - lnfree->ipc = pc; - lnfree->line = lineno; - lnfree++; - #endif /* SrcColumnInfo */ - - /* - * Could generate an Op_Line for monitoring, but don't anymore: - * - * lemitn(op, (word)lineno, name); - */ - newline(); - - #ifdef LineCodes - #ifndef EventMon - lemit(Op_Noop,"noop"); - #endif /* EventMon */ - #endif /* LineCodes */ - break; case Op_Colm: /* always recognize, maybe ignore */ - colmno = getdec(); - #ifdef SrcColumnInfo - if (lnfree >= &lntable[nsize]) - lntable = (struct ipc_line *)trealloc(lntable,&lnfree,&nsize, - sizeof(struct ipc_line), 1, "line number table"); - lnfree->ipc = pc; - lnfree->line = lineno + (colmno << 16); - lnfree++; - #endif /* SrcColumnInfo */ + if (lnfree >= &lntable[nsize]) + lntable = (struct ipc_line *)trealloc(lntable,&lnfree,&nsize, + sizeof(struct ipc_line), 1, "line number table"); + lnfree->ipc = pc; + lnfree->line = lineno + (colmno << 16); + lnfree++; break; case Op_Mark: @@ -368,10 +310,6 @@ void gencode() implicit = gp->g_flag & F_ImpError; nargs = gp->g_nargs; align(); - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "\n# procedure %s\n", &lsspace[lsfree]); - #endif /* DeBugLinker */ } else { /* @@ -488,12 +426,6 @@ static void lemit(op, name) int op; char *name; { - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%d\t\t\t\t# %s\n", (long)pc, op, name); - #endif /* DeBugLinker */ - outop(op); } @@ -503,11 +435,6 @@ char *name; { misalign(); - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%d\tL%d\t\t\t# %s\n", (long)pc, op, lab, name); - #endif /* DeBugLinker */ - if (lab >= maxlabels) labels = (word *) trealloc(labels, NULL, &maxlabels, sizeof(word), lab - maxlabels + 1, "labels"); @@ -526,13 +453,6 @@ word n; char *name; { misalign(); - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%d\t%ld\t\t\t# %s\n", (long)pc, op, (long)n, - name); - #endif /* DeBugLinker */ - outop(op); outword(n); } @@ -544,20 +464,7 @@ word loc; char *name; { misalign(); - loc -= pc + ((IntBits/ByteBits) + WordSize); - - #ifdef DeBugLinker - if (Dflag) { - if (loc >= 0) - fprintf(dbgfile, "%ld:\t%d\t*+%ld\t\t\t# %s\n",(long) pc, op, - (long)loc, name); - else - fprintf(dbgfile, "%ld:\t%d\t*-%ld\t\t\t# %s\n",(long) pc, op, - (long)-loc, name); - } - #endif /* DeBugLinker */ - outop(op); outword(loc); } @@ -568,13 +475,6 @@ word offset; char *name; { misalign(); - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%d\t%d,S+%ld\t\t\t# %s\n", (long)pc, op, n, - (long)offset, name); - #endif /* DeBugLinker */ - outop(op); outword(n); outword(offset); @@ -593,12 +493,6 @@ long i; char *name; { misalign(); - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile,"%ld:\t%d\t%ld\t\t\t# %s\n",(long)pc,op,(long)i,name); - #endif /* DeBugLinker */ - outop(op); outword(i); } @@ -628,23 +522,12 @@ register int k; x.f = lctable[k].c_val.rval; #endif /* Double */ - #ifdef DeBugLinker - if (Dflag) { - fprintf(dbgfile,"%ld:\t%d\t\t\t\t# real(%g)",(long)pc,T_Real, x.f); - dumpblock(x.ovly,sizeof(double)); - } - #endif /* DeBugLinker */ - outword(T_Real); #ifdef Double #if WordBits != 64 /* fill out real block with an empty word */ outword(0); - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile,"\t0\t\t\t\t\t# padding\n"); - #endif /* DeBugLinker */ #endif /* WordBits != 64 */ #endif /* Double */ @@ -664,23 +547,9 @@ register int k; if (Testb(i, csbuf)) j++; } - - #ifdef DeBugLinker - if (Dflag) { - fprintf(dbgfile, "%ld:\t%d\n",(long) pc, T_Cset); - fprintf(dbgfile, "\t%d\n",j); - } - #endif /* DeBugLinker */ - outword(T_Cset); outword(j); /* cset size */ outblock((char *)csbuf,sizeof(csbuf)); - - #ifdef DeBugLinker - if (Dflag) - dumpblock((char *)csbuf,CsetSize); - #endif /* DeBugLinker */ - } } @@ -699,19 +568,6 @@ int nargs, ndyn, nstat, fstat; size = (9*WordSize) + (2*WordSize) * (abs(nargs)+ndyn+nstat); p = &lsspace[name]; - #ifdef DeBugLinker - if (Dflag) { - fprintf(dbgfile, "%ld:\t%d\n", (long)pc, T_Proc); /* type code */ - fprintf(dbgfile, "\t%d\n", size); /* size of block */ - fprintf(dbgfile, "\tZ+%ld\n",(long)(pc+size)); /* entry point */ - fprintf(dbgfile, "\t%d\n", nargs); /* # arguments */ - fprintf(dbgfile, "\t%d\n", ndyn); /* # dynamic locals */ - fprintf(dbgfile, "\t%d\n", nstat); /* # static locals */ - fprintf(dbgfile, "\t%d\n", fstat); /* first static */ - fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", /* name of procedure */ - (int)strlen(p), (long)(name), p); - } - #endif /* DeBugLinker */ outword(T_Proc); outword(size); @@ -732,13 +588,6 @@ int nargs, ndyn, nstat, fstat; if (lltable[i].l_flag & F_Argument) { s_indx = lltable[i].l_name; p = &lsspace[s_indx]; - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(p), - (long)s_indx, p); - #endif /* DeBugLinker */ - outword(strlen(p)); outword(s_indx); } @@ -751,13 +600,6 @@ int nargs, ndyn, nstat, fstat; if (lltable[i].l_flag & F_Dynamic) { s_indx = lltable[i].l_name; p = &lsspace[s_indx]; - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(p), - (long)s_indx, p); - #endif /* DeBugLinker */ - outword(strlen(p)); outword(s_indx); } @@ -770,13 +612,6 @@ int nargs, ndyn, nstat, fstat; if (lltable[i].l_flag & F_Static) { s_indx = lltable[i].l_name; p = &lsspace[s_indx]; - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(p), - (long)s_indx, p); - #endif /* DeBugLinker */ - outword(strlen(p)); outword(s_indx); } @@ -802,36 +637,11 @@ void gentables() */ align(); hdr.Records = pc; - - #ifdef DeBugLinker - if (Dflag) { - fprintf(dbgfile, "\n\n# global tables\n"); - fprintf(dbgfile, "\n%ld:\t%d\t\t\t\t# record blocks\n", - (long)pc, nrecords); - } - #endif /* DeBugLinker */ - outword(nrecords); for (gp = lgfirst; gp != NULL; gp = gp->g_next) { if ((gp->g_flag & F_Record) && gp->g_procid > 0) { s = &lsspace[gp->g_name]; gp->g_pc = pc; - - #ifdef DeBugLinker - if (Dflag) { - fprintf(dbgfile, "%ld:\n", pc); - fprintf(dbgfile, "\t%d\n", T_Proc); - fprintf(dbgfile, "\t%d\n", RkBlkSize(gp)); - fprintf(dbgfile, "\t_mkrec\n"); - fprintf(dbgfile, "\t%d\n", gp->g_nargs); - fprintf(dbgfile, "\t-2\n"); - fprintf(dbgfile, "\t%d\n", gp->g_procid); - fprintf(dbgfile, "\t1\n"); - fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(s), - (long)gp->g_name, s); - } - #endif /* DeBugLinker */ - outword(T_Proc); /* type code */ outword(RkBlkSize(gp)); outword(0); /* entry point (filled in by interp)*/ @@ -860,12 +670,6 @@ void gentables() fflush(stderr); exit(1); } - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", - (int)strlen(&lsspace[fp->f_name]), - fp->f_name, &lsspace[fp->f_name]); - #endif /* DeBugLinker */ outword(strlen(&lsspace[fp->f_name])); outword(fp->f_name); foundit++; @@ -885,265 +689,25 @@ void gentables() } } - #ifndef FieldTableCompression - /* * Output record/field table (not compressed). */ hdr.Ftab = pc; - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile,"\n%ld:\t\t\t\t\t# record/field table\n",(long)pc); - #endif /* DeBugLinker */ - for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) { - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t\t\t\t\t# %s\n", (long)pc, - &lsspace[fp->f_name]); - #endif /* DeBugLinker */ rp = fp->f_rlist; for (i = 1; i <= nrecords; i++) { while (rp != NULL && rp->r_gp->g_procid < 0) rp = rp->r_link; /* skip unreferenced constructor */ if (rp != NULL && rp->r_gp->g_procid == i) { - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "\t%d\n", rp->r_fnum); - #endif /* DeBugLinker */ outop(rp->r_fnum); rp = rp->r_link; } else { - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "\t-1\n"); - #endif /* DeBugLinker */ outop(-1); } - #ifdef DeBugLinker - if (Dflag && (i == nrecords || (i & 03) == 0)) - putc('\n', dbgfile); - #endif /* DeBugLinker */ } } - #else /* FieldTableCompression */ - - /* - * Output record/field table (compressed). - * This code has not been tested recently. - */ - { - int counter = 0, f_num, first, begin, end, entries; - int *f_fo, *f_row, *f_tabp; - char *f_bm; - int pointer, first_avail = 0, inserted, bytes; - hdr.Fo = pc; - - /* - * Compute the field width required for this binary; - * it is determined by the maximum # of fields in any one record. - */ - long ct = 0; - for (gp = lgfirst; gp != NULL; gp = gp->g_next) - if ((gp->g_flag & F_Record) && gp->g_procid > 0) - if (gp->g_nargs > ct) ct=gp->g_nargs; - if (ct > 65535L) hdr.FtabWidth = 4; - else if (ct > 254) hdr.FtabWidth = 2; /* 255 is (not present) */ - else hdr.FtabWidth = 1; - - /* Find out how many field names there are. */ - hdr.Nfields = 0; - for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) - hdr.Nfields++; - - entries = hdr.Nfields * nrecords / 4 + 1; - f_tabp = malloc (entries * sizeof (int)); - for (i = 0; i < entries; i++) - f_tabp[i] = -1; - f_fo = malloc (hdr.Nfields * sizeof (int)); - - bytes = nrecords / 8; - if (nrecords % 8 != 0) - bytes++; - f_bm = calloc (hdr.Nfields, bytes); - f_row = malloc (nrecords * sizeof (int)); - f_num = 0; - - for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) { - rp = fp->f_rlist; - first = 1; - for (i = 0; i < nrecords; i++) { - while (rp != NULL && rp->r_gp->g_procid < 0) - rp = rp->r_link; /* skip unreferenced constructor */ - if (rp != NULL && rp->r_gp->g_procid == i + 1) { - if (first) { - first = 0; - begin = end = i; - } - else - end = i; - f_row[i] = rp->r_fnum; - rp = rp->r_link; - } - else { - f_row[i] = -1; - } - } - - inserted = 0; - pointer = first_avail; - while (!inserted) { - inserted = 1; - for (i = begin; i <= end; i++) { - if (pointer + (end - begin) >= entries) { - int j; - int old_entries = entries; - entries *= 2; - f_tabp = realloc (f_tabp, entries * sizeof (int)); - for (j = old_entries; j < entries; j++) - f_tabp[j] = -1; - } - if (f_row[i] != -1) - if (f_tabp[pointer + (i - begin)] != -1) { - inserted = 0; - break; - } - } - pointer++; - } - pointer--; - - /* Create bitmap */ - for (i = 0; i < nrecords; i++) { - int index = f_num * bytes + i / 8; - /* Picks out byte within bitmap row */ - if (f_row[i] != -1) { - f_bm[index] |= 01; - } - if (i % 8 != 7) - f_bm [index] <<= 1; - } - - if (nrecords%8) - f_bm[(f_num + 1) * bytes - 1] <<= 7 - (nrecords % 8); - - f_fo[f_num++] = pointer - begin; - /* So that f_fo[] points to the first bit */ - - for (i = begin; i <= end; i++) - if (f_row[i] != -1) - f_tabp[pointer + (i - begin)] = f_row[i]; - if (pointer + (end - begin) >= counter) - counter = pointer + (end - begin + 1); - while ((f_tabp[first_avail] != -1) && (first_avail <= counter)) - first_avail++; - } - - /* Write out the arrays. */ - #ifdef DeBugLinker - if (Dflag) - fprintf (dbgfile, "\n%ld:\t\t\t\t\t# field offset array\n", - (long)pc); - #endif /* DeBugLinker */ - - /* - * Compute largest value stored in fo array - */ - { - word maxfo = 0; - for (i = 0; i < hdr.Nfields; i++) { - if (f_fo[i] > maxfo) maxfo = f_fo[i]; - } - if (maxfo < 254) - hdr.FoffWidth = 1; - else if (maxfo < 65535L) - hdr.FoffWidth = 2; - else - hdr.FoffWidth = 4; - } - - for (i = 0; i < hdr.Nfields; i++) { - #ifdef DeBugLinker - if (Dflag) - fprintf (dbgfile, "\t%d\n", f_fo[i]); - #endif /* DeBugLinker */ - if (hdr.FoffWidth == 1) { - outchar(f_fo[i]); - } - else if (hdr.FoffWidth == 2) - outshort(f_fo[i]); - else - outop (f_fo[i]); - } - - #ifdef DeBugLinker - if (Dflag) - fprintf (dbgfile, "\n%ld:\t\t\t\t\t# Bit maps array\n", - (long)pc); - #endif /* DeBugLinker */ - - for (i = 0; i < hdr.Nfields; i++) { - #ifdef DeBugLinker - if (Dflag) { - int ct, index = i * bytes; - unsigned char this_bit = 0200; - - fprintf (dbgfile, "\t"); - for (ct = 0; ct < nrecords; ct++) { - if ((f_bm[index] | this_bit) == f_bm[index]) - fprintf (dbgfile, "1"); - else - fprintf (dbgfile, "0"); - - if (ct % 8 == 7) { - fprintf (dbgfile, " "); - index++; - this_bit = 0200; - } - else - this_bit >>= 1; - } - fprintf (dbgfile, "\n"); - } - #endif /* DeBugLinker */ - for (pointer = i * bytes; pointer < (i + 1) * bytes; pointer++) { - outchar (f_bm[pointer]); - } - } - - align(); - - #ifdef DeBugLinker - if (Dflag) - fprintf (dbgfile, "\n%ld:\t\t\t\t\t# record/field array\n", - (long)pc); - #endif /* DeBugLinker */ - - hdr.Ftab = pc; - for (i = 0; i < counter; i++) { - #ifdef DeBugLinker - if (Dflag) - fprintf (dbgfile, "\t%d\t%d\n", i, f_tabp[i]); - #endif /* DeBugLinker */ - if (hdr.FtabWidth == 1) - outchar(f_tabp[i]); - else if (hdr.FtabWidth == 2) - outshort(f_tabp[i]); - else - outop (f_tabp[i]); - } - - /* Free memory allocated by Jigsaw. */ - free (f_fo); - free (f_bm); - free (f_tabp); - free (f_row); - } - - #endif /* FieldTableCompression */ - /* * Output descriptors for field names. */ @@ -1151,13 +715,6 @@ void gentables() hdr.Fnames = pc; for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) { s = &lsspace[fp->f_name]; - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%d\tS+%ld\t\t\t# %s\n", - (long)pc, (int)strlen(s), (long)fp->f_name, s); - #endif /* DeBugLinker */ - outword(strlen(s)); /* name of field: length & offset */ outword(fp->f_name); } @@ -1168,38 +725,18 @@ void gentables() hdr.Globals = pc; for (gp = lgfirst; gp != NULL; gp = gp->g_next) { if (gp->g_flag & F_Builtin) { /* function */ - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%06lo\t%d\t\t\t# %s\n", - (long)pc, (long)D_Proc, -gp->g_procid, &lsspace[gp->g_name]); - #endif /* DeBugLinker */ outword(D_Proc); outword(-gp->g_procid); } else if (gp->g_flag & F_Proc) { /* Icon procedure */ - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n", - (long)pc,(long)D_Proc, (long)gp->g_pc, &lsspace[gp->g_name]); - #endif /* DeBugLinker */ outword(D_Proc); outword(gp->g_pc); } else if (gp->g_flag & F_Record) { /* record constructor */ - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n", (long) pc, - (long)D_Proc, (long)gp->g_pc, &lsspace[gp->g_name]); - #endif /* DeBugLinker */ outword(D_Proc); outword(gp->g_pc); } else { /* simple global variable */ - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%06lo\t0\t\t\t# %s\n",(long)pc, - (long)D_Null, &lsspace[gp->g_name]); - #endif /* DeBugLinker */ outword(D_Null); outword(0); } @@ -1210,14 +747,6 @@ void gentables() */ hdr.Gnames = pc; for (gp = lgfirst; gp != NULL; gp = gp->g_next) { - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t%d\tS+%ld\t\t\t# %s\n", - (long)pc, (int)strlen(&lsspace[gp->g_name]), (long)(gp->g_name), - &lsspace[gp->g_name]); - #endif /* DeBugLinker */ - outword(strlen(&lsspace[gp->g_name])); outword(gp->g_name); } @@ -1227,12 +756,6 @@ void gentables() */ hdr.Statics = pc; for (i = lstatics; i > 0; i--) { - - #ifdef DeBugLinker - if (Dflag) - fprintf(dbgfile, "%ld:\t0\t0\n", (long)pc); - #endif /* DeBugLinker */ - outword(D_Null); outword(0); } @@ -1249,20 +772,6 @@ void gentables() outfile) < 0) quit("cannot write icode file"); - #ifdef DeBugLinker - if (Dflag) { - int k = 0; - struct ipc_fname *ptr; - for (ptr = fnmtbl; ptr < fnmfree; ptr++) { - fprintf(dbgfile, "%ld:\t%03d\tS+%03d\t\t\t# %s\n", - (long)(pc + k), ptr->ipc, ptr->fname, &lsspace[ptr->fname]); - k = k + 8; - } - putc('\n', dbgfile); - } - - #endif /* DeBugLinker */ - pc += (char *)fnmfree - (char *)fnmtbl; hdr.linenums = pc; @@ -1270,47 +779,8 @@ void gentables() outfile) < 0) quit("cannot write icode file"); - #ifdef DeBugLinker - if (Dflag) { - int k = 0; - struct ipc_line *ptr; - for (ptr = lntable; ptr < lnfree; ptr++) { - fprintf(dbgfile, "%ld:\t%03d\t%03d\n", (long)(pc + k), - ptr->ipc, ptr->line); - k = k + 8; - } - putc('\n', dbgfile); - } - - #endif /* DeBugLinker */ - pc += (char *)lnfree - (char *)lntable; - hdr.Strcons = pc; - #ifdef DeBugLinker - if (Dflag) { - int c, j, k; - j = k = 0; - for (s = lsspace; s < &lsspace[lsfree]; ) { - fprintf(dbgfile, "%ld:\t%03o", (long)(pc + k), *s++ & 0377); - k = k + 8; - for (i = 7; i > 0; i--) { - if (s >= &lsspace[lsfree]) - fprintf(dbgfile," "); - else - fprintf(dbgfile, " %03o", *s++ & 0377); - } - fprintf(dbgfile, " "); - for (i = 0; i < 8; i++) - if (j < lsfree) { - c = lsspace[j++]; - putc(isprint(c & 0377) ? c : ' ', dbgfile); - } - putc('\n', dbgfile); - } - } - - #endif /* DeBugLinker */ if (longwrite(lsspace, (long)lsfree, outfile) < 0) quit("cannot write icode file"); @@ -1324,25 +794,6 @@ void gentables() strcpy((char *)hdr.config,IVersion); hdr.trace = trace; - - #ifdef DeBugLinker - if (Dflag) { - fprintf(dbgfile, "\n"); - fprintf(dbgfile, "size: %ld\n", (long)hdr.hsize); - fprintf(dbgfile, "trace: %ld\n", (long)hdr.trace); - fprintf(dbgfile, "records: %ld\n", (long)hdr.Records); - fprintf(dbgfile, "ftab: %ld\n", (long)hdr.Ftab); - fprintf(dbgfile, "fnames: %ld\n", (long)hdr.Fnames); - fprintf(dbgfile, "globals: %ld\n", (long)hdr.Globals); - fprintf(dbgfile, "gnames: %ld\n", (long)hdr.Gnames); - fprintf(dbgfile, "statics: %ld\n", (long)hdr.Statics); - fprintf(dbgfile, "strcons: %ld\n", (long)hdr.Strcons); - fprintf(dbgfile, "filenms: %ld\n", (long)hdr.Filenms); - fprintf(dbgfile, "linenums: %ld\n", (long)hdr.linenums); - fprintf(dbgfile, "config: %s\n", hdr.config); - } - #endif /* DeBugLinker */ - fseek(outfile, hdrsize, 0); if (longwrite((char *)&hdr, (long)sizeof(hdr), outfile) < 0) quit("cannot write icode file"); @@ -1407,40 +858,6 @@ int oint; codep += IntBits/ByteBits; pc += IntBits/ByteBits; } - -#ifdef FieldTableCompression -/* - * charout(i) outputs i as an unsigned char that is used by the runtime system - */ -static void charout(unsigned char ochar) - { - CodeCheck(1); - *codep++ = (unsigned char)ochar; - pc++; - } -/* - * shortout(i) outputs i as a short that is used by the runtime system - * IntBits/ByteBits bytes must be moved from &word[0] to &codep[0]. - */ -static void shortout(short oint) - { - int i; - union { - short i; - char c[2]; - } u; - - CodeCheck(2); - u.i = oint; - - for (i = 0; i < 2; i++) - codep[i] = u.c[i]; - - codep += 2; - pc += 2; - } -#endif /* FieldTableCompression */ - /* * wordout(i) outputs i as a word that is used by the runtime system @@ -1478,25 +895,6 @@ int count; *codep++ = *addr++; } -#ifdef DeBugLinker - /* - * dumpblock(a,i) dump contents of i bytes at address a, used only - * in conjunction with -L. - */ - static void dumpblock(addr, count) - char *addr; - int count; - { - int i; - for (i = 0; i < count; i++) { - if ((i & 7) == 0) - fprintf(dbgfile,"\n\t"); - fprintf(dbgfile," %03o",(0377 & (unsigned)addr[i])); - } - putc('\n',dbgfile); - } - #endif /* DeBugLinker */ - /* * flushcode - write buffered code to the output file. */ @@ -1549,16 +947,3 @@ int lab; } labels[lab] = pc; } - -#ifdef DeBugLinker - void idump(s) /* dump code region */ - char *s; - { - int *c; - - fprintf(stderr,"\ndump of code region %s:\n",s); - for (c = (int *)codeb; c < (int *)codep; c++) - fprintf(stderr,"%ld: %d\n",(long)c, (int)*c); - fflush(stderr); - } - #endif /* DeBugLinker */ diff --git a/src/icont/lglob.c b/src/icont/lglob.c index 6583b8a..281b8d5 100644 --- a/src/icont/lglob.c +++ b/src/icont/lglob.c @@ -25,7 +25,7 @@ void readglob() { register word id; register int n, op; - int k; + int i, k; int implicit; char *name; struct gentry *gp; @@ -111,7 +111,8 @@ void readglob() break; case Op_Link: /* link the named file */ - name = &lsspace[getrest()]; /* get the name and */ + i = getrest(); /* get name offset -- can move lsspace */ + name = &lsspace[i]; /* get pointer to name string */ alsolink(name); /* put it on the list of files to link */ newline(); break; diff --git a/src/icont/link.c b/src/icont/link.c index 362b257..c68ffae 100644 --- a/src/icont/link.c +++ b/src/icont/link.c @@ -19,11 +19,6 @@ static void setexe (char *fname); FILE *infile; /* input file (.u1 or .u2) */ FILE *outfile; /* interpreter code output file */ -#ifdef DeBugLinker - FILE *dbgfile; /* debug file */ - static char dbgname[MaxPath]; /* debug file name */ -#endif /* DeBugLinker */ - struct lfile *llfiles = NULL; /* List of files to link */ char inname[MaxPath]; /* input file name */ @@ -140,18 +135,6 @@ char *outname; if (ferror(outfile) != 0) quit("unable to write to icode file"); - #ifdef DeBugLinker - /* - * Open the .ux file if debugging is on. - */ - if (Dflag) { - makename(dbgname, TargetDir, llfiles->lf_name, ".ux"); - dbgfile = fopen(dbgname, "w"); - if (dbgfile == NULL) - quitf("cannot create %s", dbgname); - } - #endif /* DeBugLinker */ - /* * Loop through input files and generate code for each. */ diff --git a/src/icont/lmem.c b/src/icont/lmem.c index 8e091a5..034c4c8 100644 --- a/src/icont/lmem.c +++ b/src/icont/lmem.c @@ -96,22 +96,6 @@ void linit() putglobal(instid("main"), F_Global, 0, 0); } -#ifdef DeBugLinker - /* - * dumplfiles - print the list of files to link. Used for debugging only. - */ - void dumplfiles() - { - struct lfile *p,*lfls; - - fprintf(stderr,"lfiles:\n"); - lfls = llfiles; - while (p = getlfile(&lfls)) - fprintf(stderr,"'%s'\n",p->lf_name); - fflush(stderr); - } -#endif /* DeBugLinker */ - /* * alsolink - create an lfile structure for the named file and add it to the * end of the list of files (llfiles) to generate link instructions for. diff --git a/src/icont/tcode.c b/src/icont/tcode.c index 9a9787c..44839b6 100644 --- a/src/icont/tcode.c +++ b/src/icont/tcode.c @@ -118,9 +118,6 @@ register nodeptr t; loopsp->markcount++; traverse(Tree0(t)); /* evaluate first alternative */ loopsp->markcount--; - #ifdef EventMon - setloc(t); - #endif /* EventMon */ emit("esusp"); /* and suspend with its result */ emitl("goto", lab+1); emitlab(lab); @@ -1020,24 +1017,14 @@ nodeptr n; static void emitline(n) nodeptr n; { - #ifdef SrcColumnInfo - /* - * if either line or column has changed, emit location information - */ - if (((Col(n) << 16) + Line(n)) != lastlin) { - lastlin = (Col(n) << 16) + Line(n); - emitn("line",Line(n)); - emitn("colm",Col(n)); - } - #else /* SrcColumnInfo */ - /* - * if line has changed, emit line information - */ - if (Line(n) != lastlin) { - lastlin = Line(n); - emitn("line", lastlin); - } - #endif /* SrcColumnInfo */ + /* + * if either line or column has changed, emit location information + */ + if (((Col(n) << 16) + Line(n)) != lastlin) { + lastlin = (Col(n) << 16) + Line(n); + emitn("line",Line(n)); + emitn("colm",Col(n)); + } } /* diff --git a/src/icont/tglobals.h b/src/icont/tglobals.h index 5568293..5a45ea6 100644 --- a/src/icont/tglobals.h +++ b/src/icont/tglobals.h @@ -48,10 +48,6 @@ Global int pponly Init(0); /* -E: preprocess only */ Global int strinv Init(0); /* -f s: allow full string invocation */ Global int verbose Init(1); /* -v n: verbosity of commentary */ -#ifdef DeBugLinker - Global int Dflag Init(0); /* -L: linker debug (write .ux file) */ -#endif /* DeBugLinker */ - /* * Files and related globals. */ diff --git a/src/icont/tproto.h b/src/icont/tproto.h index aaea6c4..e88d426 100644 --- a/src/icont/tproto.h +++ b/src/icont/tproto.h @@ -94,13 +94,3 @@ void writecheck (int rc); void yyerror (int tok,struct node *lval,int state); int yylex (void); int yyparse (void); - -#ifdef DeBugTrans - void cdump (void); - void gdump (void); - void ldump (void); -#endif /* DeBugTrans */ - -#ifdef DeBugLinker - void idump (char *c); -#endif /* DeBugLinker */ diff --git a/src/icont/tsym.c b/src/icont/tsym.c index 1d0f16c..6f9b2a3 100644 --- a/src/icont/tsym.c +++ b/src/icont/tsym.c @@ -25,13 +25,6 @@ static struct tgentry *glookup (char *id); static struct tlentry *llookup (char *id); static void putglob (char *id,int id_type, int n_args); - -#ifdef DeBugTrans - void cdump (void); - void gdump (void); - void ldump (void); -#endif /* DeBugTrans */ - /* * Keyword table. @@ -257,79 +250,6 @@ register char *id; return 0; } -#ifdef DeBugTrans -/* - * ldump displays local symbol table to stdout. - */ - -void ldump() - { - register int i; - register struct tlentry *lptr; - int n; - - if (llast == NULL) - n = 0; - else - n = llast->l_index + 1; - fprintf(stderr,"Dump of local symbol table (%d entries)\n", n); - fprintf(stderr," loc blink id (name) flags\n"); - for (i = 0; i < lhsize; i++) - for (lptr = lhash[i]; lptr != NULL; lptr = lptr->l_blink) - fprintf(stderr,"%5d %5d %5d %20s %7o\n", lptr->l_index, - lptr->l_blink, lptr->l_name, lptr->l_name, lptr->l_flag); - fflush(stderr); - - } - -/* - * gdump displays global symbol table to stdout. - */ - -void gdump() - { - register int i; - register struct tgentry *gptr; - int n; - - if (glast == NULL) - n = 0; - else - n = glast->g_index + 1; - fprintf(stderr,"Dump of global symbol table (%d entries)\n", n); - fprintf(stderr," loc blink id (name) flags nargs\n"); - for (i = 0; i < ghsize; i++) - for (gptr = ghash[i]; gptr != NULL; gptr = gptr->g_blink) - fprintf(stderr,"%5d %5d %5d %20s %7o %8d\n", gptr->g_index, - gptr->g_blink, gptr->g_name, gptr->g_name, - gptr->g_flag, gptr->g_nargs); - fflush(stderr); - } - -/* - * cdump displays constant symbol table to stdout. - */ - -void cdump() - { - register int i; - register struct tcentry *cptr; - int n; - - if (clast == NULL) - n = 0; - else - n = clast->c_index + 1; - fprintf(stderr,"Dump of constant symbol table (%d entries)\n", n); - fprintf(stderr," loc blink id (name) flags\n"); - for (i = 0; i < lchsize; i++) - for (cptr = chash[i]; cptr != NULL; cptr = cptr->c_blink) - fprintf(stderr,"%5d %5d %5d %20s %7o\n", cptr->c_index, - cptr->c_blink, cptr->c_name, cptr->c_name, cptr->c_flag); - fflush(stderr); - } -#endif /* DeBugTrans */ - /* * alcloc allocates a local symbol table entry, fills in fields with * specified values and returns the new entry. diff --git a/src/icont/tunix.c b/src/icont/tunix.c index 9478403..e0388c1 100644 --- a/src/icont/tunix.c +++ b/src/icont/tunix.c @@ -103,20 +103,14 @@ int main(int argc, char *argv[]) { iconxloc = ""; break; case 'V': /* -V: print version information */ - fprintf(stderr, "%s (%s, %s)\n", Version, Config, __DATE__); + fprintf(stderr, "%s (%s %d/%d, %s)\n", + Version, Config, IntBits, WordBits, __DATE__); if (optind == argc) exit(0); break; case 'X': /* -X srcfile: execute single srcfile */ txrun(copyfile, optarg, &argv[optind]); break; /*NOTREACHED*/ - - #ifdef DeBugLinker - case 'L': /* -L: enable linker debugging */ - Dflag = 1; - break; - #endif /* DeBugLinker */ - default: case 'x': /* -x illegal until after file list */ usage(); @@ -249,8 +243,10 @@ static void execute(char *ofile, char *efile, char *args[]) { */ if (efile != NULL) { close(fileno(stderr)); - if (strcmp(efile, "-") == 0) - dup(fileno(stdout)); + if (strcmp(efile, "-") == 0) { + if (dup(fileno(stdout)) < 0) + quit("could not merge standard output with standard error\n"); + } else if (freopen(efile, "w", stderr) == NULL) quitf("could not redirect stderr to %s\n", efile); } @@ -293,11 +289,7 @@ static char *libpath(char *prog, char *envname) { s = getenv(envname); if (s != NULL) - #if CYGWIN - cygwin_win32_to_posix_path_list(s, buf); - #else /* CYGWIN */ - strcpy(buf, s); - #endif /* CYGWIN */ + strcpy(buf, s); else strcpy(buf, "."); strcat(buf, ":"); @@ -323,21 +315,15 @@ static void txrun(char *(*func)(FILE*, char*), char *source, char *args[]) { omask = umask(0077); /* remember umask; keep /tmp files private */ /* - * Invent a file named /tmp/innnnnxx.icn. + * Create a temporary file named /tmp/innnnnxx.icn. */ srand(time(NULL)); c1 = abet[rand() % (sizeof(abet) - 1)]; c2 = abet[rand() % (sizeof(abet) - 1)]; sprintf(srcfile, "/tmp/i%d%c%c.icn", getpid(), c1, c2); - - /* - * Copy the source code to the temporary file. - */ f = fopen(srcfile, "w"); if (f == NULL) quitf("cannot open for writing: %s", srcfile); - progname = func(f, source); - fclose(f); /* * Derive other names and arrange for cleanup on exit. @@ -351,8 +337,10 @@ static void txrun(char *(*func)(FILE*, char*), char *source, char *args[]) { atexit(cleanup); /* - * Translate to produce .u1 and .u2 files. + * Copy the source file, then translate to produce .u1 and .u2 files. */ + progname = func(f, source); + fclose(f); flist[0] = srcfile; flist[1] = NULL; if (trans(flist, SourceDir) > 0) diff --git a/src/preproc/Makefile b/src/preproc/Makefile deleted file mode 100644 index c3d17ed..0000000 --- a/src/preproc/Makefile +++ /dev/null @@ -1,34 +0,0 @@ -include ../../Makedefs - -POBJS = pout.o pchars.o perr.o pmem.o bldtok.o macro.o preproc.o evaluate.o\ - files.o gettok.o pinit.o - -COBJS= ../common/getopt.o ../common/time.o ../common/strtbl.o ../common/alloc.o - -ICOBJS= getopt.o time.o strtbl.o alloc.o - -OBJS= $(POBJS) $(COBJS) - -DOT_H = preproc.h pproto.h ptoken.h ../h/define.h ../h/config.h\ - ../h/typedefs.h ../h/mproto.h - -common: - cd ../common; $(MAKE) $(ICOBJS) - $(MAKE) pp - -pp: pmain.o $(OBJS) - $(CC) -o pp pmain.o $(OBJS) - -pmain.o: $(DOT_H) -p_out.o: $(DOT_H) -pchars.o: $(DOT_H) -p_err.o: $(DOT_H) -pmem.o: $(DOT_H) -pstring.o: $(DOT_H) -bldtok.o: $(DOT_H) -macro.o: $(DOT_H) -preproc.o: $(DOT_H) -evaluate.o: $(DOT_H) -files.o: $(DOT_H) -gettok.o: $(DOT_H) -p_init.o: $(DOT_H) diff --git a/src/preproc/README b/src/preproc/README deleted file mode 100644 index 35d6a23..0000000 --- a/src/preproc/README +++ /dev/null @@ -1,7 +0,0 @@ -This directory contains files for building pp, a ANSI-C preprocessor for -C (with some extensions). pp itself is not needed to build the Icon -compiler system -- the files here are automatically incorporated in -rtt. - -However, if you want to build a stand-alone version of pp for -some other use, the Makefile here will do it. diff --git a/src/preproc/files.c b/src/preproc/files.c index 07abf60..016d04d 100644 --- a/src/preproc/files.c +++ b/src/preproc/files.c @@ -5,12 +5,6 @@ #include "../preproc/preproc.h" #include "../preproc/pproto.h" -#if CYGWIN - #include <limits.h> - #include <string.h> - #include <sys/cygwin.h> -#endif /* CYGWIN */ - #define IsRelPath(fname) (fname[0] != '/') static void file_src (char *fname, FILE *f); @@ -27,12 +21,6 @@ FILE *f; { union src_ref ref; - #if CYGWIN - char posix_path[ _POSIX_PATH_MAX + 1 ]; - cygwin_conv_to_posix_path( fname, posix_path ); - fname = strdup( posix_path ); - #endif /* CYGWIN */ - ref.cs = new_cs(fname, f, CBufSize); push_src(CharSrc, &ref); next_char = NULL; @@ -154,31 +142,8 @@ char **opt_args; * that establishes these search locations. */ - #if CYGWIN - char *incl_var; - static char *sysdir = "/usr/include"; - static char *windir = "/usr/include/w32api"; - n_paths = 2; - - incl_var = getenv("C_INCLUDE_PATH"); - if (incl_var != NULL) { - /* - * Add one entry for evry non-empty, colon-separated string in incl_var. - */ - char *dir_start, *dir_end; - - dir_start = incl_var; - while( ( dir_end = strchr( dir_start, ':' ) ) != NULL ) { - if (dir_end > dir_start) ++n_paths; - dir_start = dir_end + 1; - } - if ( *dir_start != '\0' ) - ++n_paths; /* One path after the final ':' */ - } - #else /* CYGWIN */ - static char *sysdir = "/usr/include/"; - n_paths = 1; - #endif /* CYGWIN */ + static char *sysdir = "/usr/include/"; + n_paths = 1; /* * Count the number of -I options to the preprocessor. @@ -201,22 +166,6 @@ char **opt_args; s = opt_args[i]; s1 = alloc(strlen(s) + 1); strcpy(s1, s); - - #if CYGWIN - /* - * Run s1 through cygwin_conv_to_posix_path; if the posix path - * differs from s1, reset s1 to a copy of the posix path. - */ - { - char posix_path[ _POSIX_PATH_MAX ]; - cygwin_conv_to_posix_path( s1, posix_path ); - if (strcmp( s1, posix_path ) != 0) { - free( s1 ); - s1 = salloc( posix_path ); - } - } - #endif /* CYGWIN */ - incl_search[j++] = s1; } @@ -224,34 +173,7 @@ char **opt_args; * Establish the standard locations to search after the -I options * on the preprocessor. */ - #if CYGWIN - if (incl_var != NULL) { - /* - * The C_INCLUDE_PATH components are carved out of a copy of incl_var. - * The colons after non-empty directory names are replaced by null - * chars, and the pointers to the start of these names are stored - * in inc_search. - */ - char *dir_start, *dir_end; - - dir_start = salloc( incl_var ); - while( ( dir_end = strchr( dir_start, ':' ) ) != NULL ) { - if (dir_end > dir_start) { - incl_search[j++] = dir_start; - *dir_end = '\0'; - } - dir_start = dir_end + 1; - } - if ( *dir_start != '\0' ) - incl_search[j++] = dir_start; - } - - /* Finally, add the system dir(s) */ - incl_search[j++] = sysdir; - incl_search[j++] = windir; - #else - incl_search[n_paths - 1] = sysdir; - #endif /* CYGWIN */ + incl_search[n_paths - 1] = sysdir; incl_search[n_paths] = NULL; } diff --git a/src/preproc/pinit.c b/src/preproc/pinit.c index 9f64cb0..219735e 100644 --- a/src/preproc/pinit.c +++ b/src/preproc/pinit.c @@ -47,22 +47,6 @@ char **opt_args; int i; /* - * Establish predefined macros. - */ - #if CYGWIN - do_directive("#define __CYGWIN32__\n"); - do_directive("#define __CYGWIN__\n"); - do_directive("#define __unix__\n"); - do_directive("#define __unix\n"); - do_directive("#define _WIN32\n"); - do_directive("#define __WIN32\n"); - do_directive("#define __WIN32__\n"); - #else /* CYGWIN */ - do_directive("#define unix 1\n"); - do_directive(PPInit); /* defines that vary between Unix systems */ - #endif /* CYGWIN*/ - - /* * look for options that affect macro definitions (-U, -D, etc). */ for (i = 0; opt_lst[i] != '\0'; ++i) diff --git a/src/preproc/pmain.c b/src/preproc/pmain.c deleted file mode 100644 index 9cc721a..0000000 --- a/src/preproc/pmain.c +++ /dev/null @@ -1,109 +0,0 @@ -#include "../preproc/preproc.h" -#include "../preproc/pproto.h" - -char *progname = "pp"; - -/* - * Establish command-line options. - */ -static char *ostr = "+CPD:I:U:o:"; -static char *options = - "[-C] [-P] [-Dname[=[text]]] [-Uname] [-Ipath] [-ofile] [files]"; - -extern line_cntrl; - -/* - * getopt() variables - */ -extern int optind; /* index into parent argv vector */ -extern int optopt; /* character checked for validity */ -extern char *optarg; /* argument associated with option */ - -int main(argc, argv) -int argc; -char **argv; - { - int c; - char *opt_lst; - char **opt_args; - int nopts; - FILE *out_file; - - /* - * By default, keep the image of white space, but replace each comment - * by a space. By default, output #line directives. - */ - whsp_image = NoComment; - line_cntrl = 1; - - /* - * The number of options that must be passed on to other phases - * of the preprocessor are at most as large as the entire option - * list. - */ - opt_lst = alloc(argc); - opt_args = alloc(argc * sizeof (char *)); - nopts = 0; - out_file = stdout; - - /* - * Process options. - */ - while ((c = getopt(argc, argv, ostr)) != EOF) - switch (c) { - - case 'C': /* -C - retan comments */ - whsp_image = FullImage; - break; - - case 'P': /* -P - do not output #line directives */ - line_cntrl = 0; - break; - - case 'D': /* -D<id><definition> - predefine an identifier */ - case 'I': /* -I<path> - location to search for standard header files */ - case 'U': /* -U<id> - undefine predefined identifier */ - opt_lst[nopts] = c; - opt_args[nopts] = optarg; - ++nopts; - break; - - case 'o': /* -o<file> - write output to this file */ - out_file = fopen(optarg, "w"); - if (out_file == NULL) - err2("cannot open output file ", optarg); - break; - - default: - show_usage(); - } - - opt_lst[nopts] = '\0'; - - /* - * Scan file name arguments. If there are none, process standard input, - * indicated by the name "-". - */ - if (optind == argc) { - init_preproc("-", opt_lst, opt_args); - output(out_file); - } - else { - while (optind < argc) { - init_preproc(argv[optind], opt_lst, opt_args); - output(out_file); - optind++; - } - } - - return EXIT_SUCCESS; - } - -/* - * Print an error message if called incorrectly. - */ -void show_usage() - { - fprintf(stderr, "usage: %s %s\n", progname, options); - exit(EXIT_FAILURE); - } diff --git a/src/rtt/Makefile b/src/rtt/Makefile index db6445e..7122ca1 100644 --- a/src/rtt/Makefile +++ b/src/rtt/Makefile @@ -23,8 +23,6 @@ OBJ = $(ROBJS) $(POBJS) $(COBJS) rtt: $(OBJ) $(CC) $(LDFLAGS) -o rtt $(OBJ) - cp rtt ../../bin - strip ../../bin/rtt$(EXE) library: $(OBJ) rm -rf rtt.a diff --git a/src/rtt/rttdb.c b/src/rtt/rttdb.c index 22368fe..e38dd5f 100644 --- a/src/rtt/rttdb.c +++ b/src/rtt/rttdb.c @@ -542,7 +542,7 @@ struct il_code *il; fprintf(db, "%d ", num_cases); indx = 1; for (i = 0; i < num_cases; ++i) { - fprintf(db, "\n%d ", il->u[indx++].n); /* selection number */ + fprintf(db, "\n%ld ", (long)il->u[indx++].n);/* selection number */ put_inlin(db, il->u[indx++].fld); /* action */ } fprintf(db, "\n"); @@ -567,14 +567,14 @@ struct il_code *il; * runerr with no value argument. */ fprintf(db, "runerr1 "); - fprintf(db, "%d ", il->u[0].n); /* error number */ + fprintf(db, "%ld ", (long)il->u[0].n); /* error number */ break; case IL_Err2: /* * runerr with a value argument. */ fprintf(db, "runerr2 "); - fprintf(db, "%d ", il->u[0].n); /* error number */ + fprintf(db, "%ld ", (long)il->u[0].n); /* error number */ put_inlin(db, il->u[1].fld); /* variable */ break; case IL_Lst: @@ -649,15 +649,15 @@ struct il_code *il; /* * A variable. */ - fprintf(db, "%d ", il->u[0].n); /* symbol table index */ + fprintf(db, "%ld ", (long)il->u[0].n); /* symbol table index */ break; case IL_Subscr: /* * A subscripted variable. */ fprintf(db, "[ "); - fprintf(db, "%d ", il->u[0].n); /* symbol table index */ - fprintf(db, "%d ", il->u[1].n); /* subscripting index */ + fprintf(db, "%ld ", (long)il->u[0].n); /* symbol table index */ + fprintf(db, "%ld ", (long)il->u[1].n); /* subscripting index */ break; case IL_Block: /* @@ -671,7 +671,7 @@ struct il_code *il; /* * Output a symbol table of tended variables. */ - fprintf(db, "%d ", il->u[1].n); /* number of local tended */ + fprintf(db, "%ld ", (long)il->u[1].n); /* number of local tended */ for (i = 2; i - 2 < il->u[1].n; ++i) switch (il->u[i].n) { case TndDesc: @@ -733,8 +733,8 @@ struct il_code *il; else fprintf(db, "f "); - fprintf(db, "%d ", il->u[5].n); /* num string bufs */ - fprintf(db, "%d ", il->u[6].n); /* num cset bufs */ + fprintf(db, "%ld ", (long)il->u[5].n); /* num string bufs */ + fprintf(db, "%ld ", (long)il->u[6].n); /* num cset bufs */ i = il->u[7].n; fprintf(db, "%d ", i); /* num args */ indx = 8; @@ -961,15 +961,15 @@ struct il_c *ilc; fprintf(db, "$efail "); /* errorfail statement */ break; case ILC_Goto: - fprintf(db, "$goto %d ", ilc->n); /* goto label */ + fprintf(db, "$goto %ld ", (long)ilc->n); /* goto label */ break; case ILC_CGto: fprintf(db, "$cgoto "); /* conditional goto */ put_ilc(db, ilc->code[0]); /* condition (with $c $e) */ - fprintf(db, "%d ", ilc->n); /* label */ + fprintf(db, "%ld ", (long)ilc->n); /* label */ break; case ILC_Lbl: - fprintf(db, "$lbl %d ", ilc->n); /* label */ + fprintf(db, "$lbl %ld ", (long)ilc->n); /* label */ break; case ILC_LBrc: fprintf(db, "${ "); /* start of C block with dcls */ @@ -1000,7 +1000,7 @@ struct il_c *ilc; if (ilc->n == RsltIndx) fprintf(db, "r "); /* this is "result" */ else - fprintf(db, "%d ", ilc->n); /* offset into a symbol table */ + fprintf(db, "%ld ", (long)ilc->n); /* offset into a symbol table */ } /* diff --git a/src/rtt/rttilc.c b/src/rtt/rttilc.c index 70839ef..a660829 100644 --- a/src/rtt/rttilc.c +++ b/src/rtt/rttilc.c @@ -847,25 +847,11 @@ int const_cast; } else if (typcd == int_typ) { ForceNl(); - prt_str("#ifdef LargeInts", 0); - ForceNl(); - ilc_str("((("); ilc_walk(n1, 0, 0); ilc_str(").dword == D_Integer) || (("); ilc_walk(n1, 0, 0); ilc_str(").dword == D_Lrgint))"); - - ForceNl(); - prt_str("#else /* LargeInts */", 0); - ForceNl(); - - ilc_str("(("); - ilc_walk(n1, 0, 0); - ilc_str(").dword == D_Integer)"); - - ForceNl(); - prt_str("#endif /* LargeInts */", 0); ForceNl(); } else { diff --git a/src/rtt/rttmain.c b/src/rtt/rttmain.c index 2099c2f..bfdf643 100644 --- a/src/rtt/rttmain.c +++ b/src/rtt/rttmain.c @@ -24,8 +24,8 @@ static char *options = * interpreted as relative to where rtt.exe is or where rtt.exe is * invoked. */ - char *grttin_path = "../src/h/grttin.h"; - char *rt_path = "../src/h/rt.h"; + char *grttin_path = "../h/grttin.h"; + char *rt_path = "../h/rt.h"; /* * Note: rtt presently does not process system include files. If this @@ -39,7 +39,7 @@ char *compiler_def; FILE *out_file; char *inclname; int def_fnd; -char *largeints = NULL; +char *largeints = "LargeInts"; int iconx_flg = 0; int enable_out = 0; @@ -245,12 +245,9 @@ char *src_file; char *cname; char buf[MaxPath]; /* file name construction buffer */ char *buf_ptr; - char *s; struct fileparts *fp; struct tdefnm *td; struct token *t; - static char *test_largeints = "#ifdef LargeInts\nyes\n#endif\n"; - static int first_time = 1; cur_src = src_file; @@ -266,24 +263,6 @@ char *src_file; sym_add(TypeDefName, td->name, OtherDcl, 1); init_lex(); yyparse(); - if (first_time) { - first_time = 0; - /* - * Now that the standard include files have been processed, see if - * Largeints is defined and make sure it matches what's in the data base. - */ - s = "NoLargeInts"; - str_src("<rtt initialization>", test_largeints, - (int)strlen(test_largeints)); - while ((t = preproc()) != NULL) - if (strcmp(t->image, "yes")) - s = "LargeInts"; - if (largeints == NULL) - largeints = s; - else if (strcmp(largeints, s) != 0) - err2("header file definition of LargeInts/NoLargeInts does not match ", - dbname); - } enable_out = 1; /* diff --git a/src/rtt/rttout.c b/src/rtt/rttout.c index 14c71b7..c2fa8b0 100644 --- a/src/rtt/rttout.c +++ b/src/rtt/rttout.c @@ -566,22 +566,12 @@ int indent; * an ordinary integer or a large integer. */ ForceNl(); - prt_str("#ifdef LargeInts", 0); - ForceNl(); prt_str("(((", indent); c_walk(desc, indent, 0); prt_str(").dword == D_Integer) || ((", indent); c_walk(desc, indent, 0); prt_str(").dword == D_Lrgint))", indent); ForceNl(); - prt_str("#else\t\t\t\t\t/* LargeInts */", 0); - ForceNl(); - prt_str("((", indent); - c_walk(desc, indent, 0); - prt_str(").dword == D_Integer)", indent); - ForceNl(); - prt_str("#endif\t\t\t\t\t/* LargeInts */", 0); - ForceNl(); } else { /* @@ -1393,29 +1383,9 @@ int brace; * is returned. */ if (iconx_flg) { - #ifdef EventMon - switch (op_type) { - case TokFunction: - prt_str( - "if ((signal = interp(G_Fsusp, r_args)) != A_Resume) {", - indent); - break; - case Operator: - case Keyword: - prt_str( - "if ((signal = interp(G_Osusp, r_args)) != A_Resume) {", - indent); - break; - default: - prt_str( - "if ((signal = interp(G_Csusp, r_args)) != A_Resume) {", - indent); - } - #else /* EventMon */ - prt_str( - "if ((signal = interp(G_Csusp, r_args)) != A_Resume) {", - indent); - #endif /* EventMon */ + prt_str( + "if ((signal = interp(G_Csusp, r_args)) != A_Resume) {", + indent); } else { prt_str("if (r_s_cont == (continuation)NULL) {", indent); @@ -2153,12 +2123,8 @@ int indent; if (typcd == int_typ) { ForceNl(); - prt_str("#ifdef LargeInts", 0); - ForceNl(); prt_str("case T_Lrgint: ", indent + IndentInc); ForceNl(); - prt_str("#endif /* LargeInts */", 0); - ForceNl(); } prt_str("case T_", indent + IndentInc); @@ -2681,8 +2647,6 @@ int brace; /* * Try converting both arguments to an integer. */ - prt_str("#ifdef LargeInts", 0); - ForceNl(); ld_prmloc(strt_prms); tok_line(t, indent); prt_str("else if (", indent); @@ -2696,8 +2660,6 @@ int brace; mrg_prmloc(end_prms); } ForceNl(); - prt_str("#endif\t\t\t\t\t/* LargeInts */", 0); - ForceNl(); /* * Try converting both arguments to a C_double diff --git a/src/runtime/Makefile b/src/runtime/Makefile index ffa63e8..c47c14e 100644 --- a/src/runtime/Makefile +++ b/src/runtime/Makefile @@ -3,512 +3,55 @@ include ../../Makedefs -HDRS = ../h/define.h ../h/config.h ../h/typedefs.h ../h/monitor.h\ +HDRS = ../h/define.h ../h/arch.h ../h/config.h ../h/typedefs.h \ ../h/cstructs.h ../h/cpuconf.h ../h/grttin.h\ ../h/rmacros.h ../h/rexterns.h ../h/rstructs.h \ ../h/rproto.h ../h/mproto.h ../h/sys.h -GRAPHICSHDRS = ../h/graphics.h ../h/xwin.h ../h/mswin.h +GHDRS = ../h/graphics.h ../h/xwin.h ../h/mswin.h COBJS = ../common/long.o ../common/time.o \ ../common/rswitch.o ../common/xwindow.o \ ../common/alloc.o ../common/filepart.o ../common/munix.o +XOBJS = cnv.o data.o def.o errmsg.o fconv.o fload.o fmath.o\ + fmisc.o fscan.o fstr.o fstranl.o fstruct.o fsys.o\ + fwindow.o imain.o imisc.o init.o interp.o invoke.o\ + keyword.o lmisc.o oarith.o oasgn.o ocat.o ocomp.o\ + omisc.o oref.o oset.o ovalue.o ralc.o rcoexpr.o rcomp.o\ + rdebug.o rexternal.o rlrgint.o rmemmgt.o rmisc.o rstruct.o \ + rsys.o rwinrsc.o rwinsys.o rwindow.o rcolor.o rimage.o -default: iconx -all: iconx comp_all +RTT = ../rtt/rtt +SUFFIXES = .r .c .o +.r.o: ; $(RTT) -x $*.r && $(CC) -o $*.o -c $(CFLAGS) x$*.c && rm x$*.c +.r.c: ; $(RTT) -x $*.r -$(COBJS): - cd ../common; $(MAKE) - - -#################################################################### -# -# Make entries for iconx -# - -XOBJS = xcnv.o xdata.o xdef.o xerrmsg.o xextcall.o xfconv.o xfload.o xfmath.o\ - xfmisc.o xfmonitr.o xfscan.o xfstr.o xfstranl.o xfstruct.o xfsys.o\ - xfwindow.o ximain.o ximisc.o xinit.o xinterp.o xinvoke.o\ - xkeyword.o xlmisc.o xoarith.o xoasgn.o xocat.o xocomp.o\ - xomisc.o xoref.o xoset.o xovalue.o xralc.o xrcoexpr.o xrcomp.o\ - xrdebug.o xrlrgint.o xrmemmgt.o xrmisc.o xrstruct.o xrsys.o\ - xrwinrsc.o xrwinsys.o xrwindow.o xrcolor.o xrimage.o - -OBJS = $(XOBJS) $(COBJS) -iconx: $(OBJS) +iconx: $(COBJS) $(XOBJS) cd ../common; $(MAKE) - $(CC) $(RLINK) -o iconx $(OBJS) $(XL) $(RLIBS) $(TL) + $(CC) $(RLINK) -o iconx $(XOBJS) $(COBJS) $(XL) $(RLIBS) $(TLIBS) cp iconx ../../bin strip $(SFLAGS) ../../bin/iconx$(EXE) -xcnv.o: cnv.r $(HDRS) - ../../bin/rtt -x cnv.r - $(CC) -c $(CFLAGS) xcnv.c - rm xcnv.c - -xdata.o: data.r $(HDRS) ../h/kdefs.h ../h/fdefs.h ../h/odefs.h - ../../bin/rtt -x data.r - $(CC) -c $(CFLAGS) xdata.c - rm xdata.c - -xdef.o: def.r $(HDRS) - ../../bin/rtt -x def.r - $(CC) -c $(CFLAGS) xdef.c - rm xdef.c - -xerrmsg.o: errmsg.r $(HDRS) - ../../bin/rtt -x errmsg.r - $(CC) -c $(CFLAGS) xerrmsg.c - rm xerrmsg.c - -xextcall.o: extcall.r $(HDRS) - ../../bin/rtt -x extcall.r - $(CC) -c $(CFLAGS) xextcall.c - rm xextcall.c - -xfconv.o: fconv.r $(HDRS) - ../../bin/rtt -x fconv.r - $(CC) -c $(CFLAGS) xfconv.c - rm xfconv.c - -xfload.o: fload.r $(HDRS) - ../../bin/rtt -x fload.r - $(CC) -c $(CFLAGS) xfload.c - rm xfload.c - -xfmath.o: fmath.r $(HDRS) - ../../bin/rtt -x fmath.r - $(CC) -c $(CFLAGS) xfmath.c - rm xfmath.c - -xfmisc.o: fmisc.r $(HDRS) - ../../bin/rtt -x fmisc.r - $(CC) -c $(CFLAGS) xfmisc.c - rm xfmisc.c - -xfmonitr.o: fmonitr.r $(HDRS) - ../../bin/rtt -x fmonitr.r - $(CC) -c $(CFLAGS) xfmonitr.c - rm xfmonitr.c - -xfscan.o: fscan.r $(HDRS) - ../../bin/rtt -x fscan.r - $(CC) -c $(CFLAGS) xfscan.c - rm xfscan.c - -xfstr.o: fstr.r $(HDRS) - ../../bin/rtt -x fstr.r - $(CC) -c $(CFLAGS) xfstr.c - rm xfstr.c - -xfstranl.o: fstranl.r $(HDRS) - ../../bin/rtt -x fstranl.r - $(CC) -c $(CFLAGS) xfstranl.c - rm xfstranl.c - -xfstruct.o: fstruct.r $(HDRS) - ../../bin/rtt -x fstruct.r - $(CC) -c $(CFLAGS) xfstruct.c - rm xfstruct.c - -xfsys.o: fsys.r $(HDRS) - ../../bin/rtt -x fsys.r - $(CC) -c $(CFLAGS) xfsys.c - rm xfsys.c - -xfwindow.o: fwindow.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt -x fwindow.r - $(CC) -c $(CFLAGS) xfwindow.c - rm xfwindow.c - -ximain.o: imain.r $(HDRS) ../h/version.h - ../../bin/rtt -x imain.r - $(CC) -c $(CFLAGS) ximain.c - rm ximain.c - -ximisc.o: imisc.r $(HDRS) - ../../bin/rtt -x imisc.r - $(CC) -c $(CFLAGS) ximisc.c - rm ximisc.c - -xinit.o: init.r $(HDRS) ../h/odefs.h ../h/version.h - ../../bin/rtt -x init.r - $(CC) -c $(CFLAGS) xinit.c - rm xinit.c - -xinterp.o: interp.r $(HDRS) - ../../bin/rtt -x interp.r - $(CC) -c $(CFLAGS) xinterp.c - rm xinterp.c - -xinvoke.o: invoke.r $(HDRS) - ../../bin/rtt -x invoke.r - $(CC) -c $(CFLAGS) xinvoke.c - rm xinvoke.c - -xkeyword.o: keyword.r $(HDRS) ../h/features.h ../h/version.h - ../../bin/rtt -x keyword.r - $(CC) -c $(CFLAGS) xkeyword.c - rm xkeyword.c - -xlmisc.o: lmisc.r $(HDRS) - ../../bin/rtt -x lmisc.r - $(CC) -c $(CFLAGS) xlmisc.c - rm xlmisc.c - -xoarith.o: oarith.r $(HDRS) - ../../bin/rtt -x oarith.r - $(CC) -c $(CFLAGS) xoarith.c - rm xoarith.c - -xoasgn.o: oasgn.r $(HDRS) - ../../bin/rtt -x oasgn.r - $(CC) -c $(CFLAGS) xoasgn.c - rm xoasgn.c - -xocat.o: ocat.r $(HDRS) - ../../bin/rtt -x ocat.r - $(CC) -c $(CFLAGS) xocat.c - rm xocat.c - -xocomp.o: ocomp.r $(HDRS) - ../../bin/rtt -x ocomp.r - $(CC) -c $(CFLAGS) xocomp.c - rm xocomp.c - -xomisc.o: omisc.r $(HDRS) - ../../bin/rtt -x omisc.r - $(CC) -c $(CFLAGS) xomisc.c - rm xomisc.c - -xoref.o: oref.r $(HDRS) - ../../bin/rtt -x oref.r - $(CC) -c $(CFLAGS) xoref.c - rm xoref.c - -xoset.o: oset.r $(HDRS) - ../../bin/rtt -x oset.r - $(CC) -c $(CFLAGS) xoset.c - rm xoset.c - -xovalue.o: ovalue.r $(HDRS) - ../../bin/rtt -x ovalue.r - $(CC) -c $(CFLAGS) xovalue.c - rm xovalue.c - -xralc.o: ralc.r $(HDRS) - ../../bin/rtt -x ralc.r - $(CC) -c $(CFLAGS) xralc.c - rm xralc.c - -xrcoexpr.o: rcoexpr.r $(HDRS) - ../../bin/rtt -x rcoexpr.r - $(CC) -c $(CFLAGS) xrcoexpr.c - rm xrcoexpr.c - -xrcomp.o: rcomp.r $(HDRS) - ../../bin/rtt -x rcomp.r - $(CC) -c $(CFLAGS) xrcomp.c - rm xrcomp.c - -xrdebug.o: rdebug.r $(HDRS) - ../../bin/rtt -x rdebug.r - $(CC) -c $(CFLAGS) xrdebug.c - rm xrdebug.c - -xrlrgint.o: rlrgint.r $(HDRS) - ../../bin/rtt -x rlrgint.r - $(CC) -c $(CFLAGS) xrlrgint.c - rm xrlrgint.c - -xrmemmgt.o: rmemmgt.r $(HDRS) - ../../bin/rtt -x rmemmgt.r - $(CC) -c $(CFLAGS) xrmemmgt.c - rm xrmemmgt.c - -xrmisc.o: rmisc.r $(HDRS) - ../../bin/rtt -x rmisc.r - $(CC) -c $(CFLAGS) xrmisc.c - rm xrmisc.c - -xrstruct.o: rstruct.r $(HDRS) - ../../bin/rtt -x rstruct.r - $(CC) -c $(CFLAGS) xrstruct.c - rm xrstruct.c - -xrsys.o: rsys.r $(HDRS) - ../../bin/rtt -x rsys.r - $(CC) -c $(CFLAGS) xrsys.c - rm xrsys.c - -xrwinrsc.o: rwinrsc.r $(HDRS) $(GRAPHICSHDRS) rxrsc.ri - ../../bin/rtt -x rwinrsc.r - $(CC) -c $(CFLAGS) xrwinrsc.c - rm xrwinrsc.c - -xrwinsys.o: rwinsys.r $(HDRS) $(GRAPHICSHDRS) rxwin.ri - ../../bin/rtt -x rwinsys.r - $(CC) -c $(CFLAGS) xrwinsys.c - rm xrwinsys.c - -xrwindow.o: rwindow.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt -x rwindow.r - $(CC) -c $(CFLAGS) xrwindow.c - rm xrwindow.c - -xrcolor.o: rcolor.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt -x rcolor.r - $(CC) -c $(CFLAGS) xrcolor.c - rm xrcolor.c - -xrimage.o: rimage.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt -x rimage.r - $(CC) -c $(CFLAGS) xrimage.c - rm xrimage.c - - -#################################################################### -# -# Make entries for the compiler library -# - -comp_all: $(COBJS) db_lib - -db_lib: rt.db rt.a - -# -# if rt.db is missing or any header files have been updated, recreate -# rt.db from scratch along with the .o files. -# -rt.db: $(HDRS) - rm -f rt.db rt.a - ../../bin/rtt cnv.r data.r def.r errmsg.r fconv.r fload.r fmath.r\ - fmisc.r fmonitr.r fscan.r fstr.r fstranl.r fstruct.r\ - fsys.r fwindow.r init.r invoke.r keyword.r\ - lmisc.r oarith.r oasgn.r ocat.r ocomp.r omisc.r\ - oref.r oset.r ovalue.r ralc.r rcoexpr.r rcomp.r\ - rdebug.r rlrgint.r rmemmgt.r rmisc.r rstruct.r\ - rsys.r rwinrsc.r rwinsys.r rwindow.r rcolor.r rimage.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -rt.a: ../common/rswitch.o ../common/long.o ../common/time.o\ - cnv.o data.o def.o errmsg.o fconv.o fload.o fmath.o fmisc.o fmonitr.o \ - fscan.o fstr.o fstranl.o fstruct.o fsys.o fwindow.o init.o invoke.o\ - keyword.o lmisc.o oarith.o oasgn.o ocat.o ocomp.o omisc.o oref.o oset.o\ - ovalue.o ralc.o rcoexpr.o rcomp.o rdebug.o rlrgint.o rmemmgt.o\ - rmisc.o rstruct.o rsys.o rwinrsc.o rwinsys.o\ - rwindow.o rcolor.o rimage.o ../common/xwindow.o ../common/alloc.o - rm -f rt.a - ar qc rt.a `sed 's/$$/.o/' rttcur.lst` ../common/rswitch.o\ - ../common/long.o ../common/time.o\ - ../common/xwindow.o ../common/alloc.o - ranlib rt.a 2>/dev/null || : - cp -p rt.a rt.db ../common/dlrgint.o ../../bin - -cnv.o: cnv.r $(HDRS) - ../../bin/rtt cnv.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -data.o: data.r $(HDRS) - ../../bin/rtt data.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -def.o: def.r $(HDRS) - ../../bin/rtt def.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -errmsg.o: errmsg.r $(HDRS) - ../../bin/rtt errmsg.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fconv.o: fconv.r $(HDRS) - ../../bin/rtt fconv.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fload.o: fload.r $(HDRS) - ../../bin/rtt fload.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fmath.o: fmath.r $(HDRS) - ../../bin/rtt fmath.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fmisc.o: fmisc.r $(HDRS) - ../../bin/rtt fmisc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fmonitr.o: fmonitr.r $(HDRS) - ../../bin/rtt fmonitr.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fscan.o: fscan.r $(HDRS) - ../../bin/rtt fscan.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fstr.o: fstr.r $(HDRS) - ../../bin/rtt fstr.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fstranl.o: fstranl.r $(HDRS) - ../../bin/rtt fstranl.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fstruct.o: fstruct.r $(HDRS) - ../../bin/rtt fstruct.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fsys.o: fsys.r $(HDRS) - ../../bin/rtt fsys.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -fwindow.o: fwindow.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt fwindow.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -init.o: init.r $(HDRS) - ../../bin/rtt init.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -invoke.o: invoke.r $(HDRS) - ../../bin/rtt invoke.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -keyword.o: keyword.r $(HDRS) - ../../bin/rtt keyword.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -lmisc.o: lmisc.r $(HDRS) - ../../bin/rtt lmisc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -oarith.o: oarith.r $(HDRS) - ../../bin/rtt oarith.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -oasgn.o: oasgn.r $(HDRS) - ../../bin/rtt oasgn.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -ocat.o: ocat.r $(HDRS) - ../../bin/rtt ocat.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -ocomp.o: ocomp.r $(HDRS) - ../../bin/rtt ocomp.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -omisc.o: omisc.r $(HDRS) - ../../bin/rtt omisc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -oref.o: oref.r $(HDRS) - ../../bin/rtt oref.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -oset.o: oset.r $(HDRS) - ../../bin/rtt oset.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -ovalue.o: ovalue.r $(HDRS) - ../../bin/rtt ovalue.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -ralc.o: ralc.r $(HDRS) - ../../bin/rtt ralc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -rcoexpr.o: rcoexpr.r $(HDRS) - ../../bin/rtt rcoexpr.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -rcomp.o: rcomp.r $(HDRS) - ../../bin/rtt rcomp.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` - -rdebug.o: rdebug.r $(HDRS) - ../../bin/rtt rdebug.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +$(COBJS): + cd ../common; $(MAKE) -rlrgint.o: rlrgint.r $(HDRS) - ../../bin/rtt rlrgint.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` -rmemmgt.o: rmemmgt.r $(HDRS) - ../../bin/rtt rmemmgt.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +$(XOBJS): $(HDRS) $(GHDRS) -rmisc.o: rmisc.r $(HDRS) - ../../bin/rtt rmisc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +data.o: ../h/fdefs.h ../h/odefs.h ../h/kdefs.h -rstruct.o: rstruct.r $(HDRS) - ../../bin/rtt rstruct.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +fmisc.o: ../h/opdefs.h -rsys.o: rsys.r $(HDRS) - ../../bin/rtt rsys.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +imain.o: ../h/version.h ../h/header.h ../h/opdefs.h ../h/version.h -rwinrsc.o: rwinrsc.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt rwinrsc.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +init.o: ../h/header.h ../h/odefs.h ../h/version.h -rwinsys.o: rwinsys.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt rwinsys.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +keyword.o: ../h/kdefs.h ../h/features.h ../h/version.h -rwindow.o: rwindow.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt rwindow.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +rdebug.o: ../h/opdefs.h -rcolor.o: rcolor.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt rcolor.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +rwinrsc.o: rxrsc.ri -rimage.o: rimage.r $(HDRS) $(GRAPHICSHDRS) - ../../bin/rtt rimage.r - $(CC) -c $(CFLAGS) `sed 's/$$/.c/' rttcur.lst` - rm `sed 's/$$/.c/' rttcur.lst` +rwinsys.o: rxwin.ri rmswin.ri diff --git a/src/runtime/cnv.r b/src/runtime/cnv.r index 23e1767..5661deb 100644 --- a/src/runtime/cnv.r +++ b/src/runtime/cnv.r @@ -14,9 +14,6 @@ * Assumed: the C compiler must handle assignments of C integers to * C double variables and vice-versa. Hopefully production C compilers * have managed to eliminate bugs related to these assignments. - * - * Note: calls beginning with EV are empty macros unless EventMon - * is defined. */ #define tonum(c) (isdigit(c) ? (c)-'0' : 10+(((c)|(040))-'a')) @@ -46,15 +43,10 @@ double *d; return 1; } integer: { - -#ifdef LargeInts if (Type(*s) == T_Lrgint) *d = bigtoreal(s); else -#endif /* LargeInts */ - *d = IntVal(*s); - return 1; } string: { @@ -76,15 +68,11 @@ double *d; case T_Integer: *d = numrc.integer; return 1; - -#ifdef LargeInts case T_Lrgint: result.dword = D_Lrgint; BlkLoc(result) = (union block *)numrc.big; *d = bigtoreal(&result); return 1; -#endif /* LargeInts */ - case T_Real: *d = numrc.real; return 1; @@ -106,13 +94,9 @@ C_integer *d; type_case *s of { integer: { - -#ifdef LargeInts if (Type(*s) == T_Lrgint) { return 0; } -#endif /* LargeInts */ - *d = IntVal(*s); return 1; } @@ -212,12 +196,8 @@ dptr s, d; register C_integer l; register char *s1; /* does not need to be tended */ - EVValD(s, E_Aconv); - EVValD(&csetdesc, E_Tconv); - if (is:cset(*s)) { *d = *s; - EVValD(s, E_Nconv); return 1; } /* @@ -232,11 +212,9 @@ dptr s, d; Setb(*s1, *d); s1++; } - EVValD(d, E_Sconv); return 1; } else { - EVValD(s, E_Fconv); return 0; } } @@ -254,12 +232,9 @@ C_integer *d; type_case *s of { integer: { - -#ifdef LargeInts if (Type(*s) == T_Lrgint) { return 0; } -#endif /* LargeInts */ *d = IntVal(*s); return 1; } @@ -321,14 +296,10 @@ dptr s, d; case T_Integer: MakeInt(numrc.integer, d); return 1; - -#ifdef LargeInts case T_Lrgint: d->dword = D_Lrgint; BlkLoc(*d) = (union block *)numrc.big; return 1; -#endif /* LargeInts */ - default: return 0; } @@ -344,36 +315,23 @@ dptr s, d; char sbuf[MaxCvtLen]; union numeric numrc; - EVValD(s, E_Aconv); - EVValD(&zerodesc, E_Tconv); - type_case *s of { integer: { *d = *s; - EVValD(s, E_Nconv); return 1; } real: { double dbl; GetReal(s,dbl); if (dbl > MaxLong || dbl < MinLong) { - -#ifdef LargeInts if (realtobig(s, d) == Succeeded) { - EVValD(d, E_Sconv); return 1; } else { - EVValD(s, E_Fconv); return 0; } -#else /* LargeInts */ - EVValD(s, E_Fconv); - return 0; -#endif /* LargeInts */ } MakeInt((word)dbl,d); - EVValD(d, E_Sconv); return 1; } string: { @@ -384,7 +342,6 @@ dptr s, d; s = &cnvstr; } default: { - EVValD(s, E_Fconv); return 0; } } @@ -393,43 +350,25 @@ dptr s, d; * s is now a string. */ switch( ston(s, &numrc) ) { - -#ifdef LargeInts case T_Lrgint: d->dword = D_Lrgint; BlkLoc(*d) = (union block *)numrc.big; - EVValD(d, E_Sconv); return 1; -#endif /* LargeInts */ - case T_Integer: MakeInt(numrc.integer,d); - EVValD(d, E_Sconv); return 1; case T_Real: { double dbl = numrc.real; if (dbl > MaxLong || dbl < MinLong) { - -#ifdef LargeInts - if (realtobig(s, d) == Succeeded) { - EVValD(d, E_Sconv); + if (realtobig(s, d) == Succeeded) return 1; - } - else { - EVValD(s, E_Fconv); + else return 0; - } -#else /* LargeInts */ - EVValD(s, E_Fconv); - return 0; -#endif /* LargeInts */ - } + } MakeInt((word)dbl,d); - EVValD(d, E_Sconv); return 1; } default: - EVValD(s, E_Fconv); return 0; } } @@ -442,17 +381,12 @@ dptr s, d; { double dbl; - EVValD(s, E_Aconv); - EVValD(&rzerodesc, E_Tconv); - if (cnv_c_dbl(s, &dbl)) { Protect(BlkLoc(*d) = (union block *)alcreal(dbl), fatalerr(0,NULL)); d->dword = D_Real; - EVValD(d, E_Sconv); return 1; } else - EVValD(s, E_Fconv); return 0; } @@ -464,31 +398,23 @@ dptr s, d; { char sbuf[MaxCvtLen]; - EVValD(s, E_Aconv); - EVValD(&emptystr, E_Tconv); - type_case *s of { string: { *d = *s; - EVValD(s, E_Nconv); return 1; } integer: { - -#ifdef LargeInts if (Type(*s) == T_Lrgint) { word slen; word dlen; slen = (BlkLoc(*s)->bignumblk.lsd - BlkLoc(*s)->bignumblk.msd +1); dlen = slen * NB * 0.3010299956639812; /* 1 / log2(10) */ - bigtos(s,d); - } + bigtos(s,d); + } else -#endif /* LargeInts */ - - itos(IntVal(*s), d, sbuf); - } + itos(IntVal(*s), d, sbuf); + } real: { double res; GetReal(s, res); @@ -497,12 +423,10 @@ dptr s, d; cset: cstos(BlkLoc(*s)->cset.bits, d, sbuf); default: { - EVValD(s, E_Fconv); return 0; } } Protect(StrLoc(*d) = alcstr(StrLoc(*d), StrLen(*d)), fatalerr(0,NULL)); - EVValD(d, E_Sconv); return 1; } @@ -518,12 +442,8 @@ dptr s, d; register char *s1; C_integer l; - EVValD(s, E_Aconv); - EVValD(&csetdesc, E_Tconv); - if (is:cset(*s)) { *d = *s; - EVValD(s, E_Nconv); return 1; } if (tmp_str(sbuf, s, &tmpstr)) { @@ -537,11 +457,9 @@ dptr s, d; Setb(*s1, *d); s1++; } - EVValD(d, E_Sconv); return 1; } else { - EVValD(s, E_Fconv); return 0; } } @@ -554,20 +472,14 @@ char *sbuf; dptr s; dptr d; { - EVValD(s, E_Aconv); - EVValD(&emptystr, E_Tconv); - if (is:string(*s)) { *d = *s; - EVValD(s, E_Nconv); return 1; } else if (tmp_str(sbuf, s, d)) { - EVValD(d, E_Sconv); return 1; } else { - EVValD(s, E_Fconv); return 0; } } @@ -661,21 +573,17 @@ dptr d; string: *d = *s; integer: { - -#ifdef LargeInts if (Type(*s) == T_Lrgint) { word slen; word dlen; slen = (BlkLoc(*s)->bignumblk.lsd - BlkLoc(*s)->bignumblk.msd +1); dlen = slen * NB * 0.3010299956639812; /* 1 / log2(10) */ - bigtos(s,d); - } + bigtos(s,d); + } else -#endif /* LargeInts */ - - itos(IntVal(*s), d, sbuf); - } + itos(IntVal(*s), d, sbuf); + } real: { double res; GetReal(s, res); @@ -731,16 +639,10 @@ C_integer arity; /* * See if the string represents a built-in function. */ -#if COMPILER - for (i = 0; i < n_globals; ++i) - if (eq(s, &gnames[i])) - return builtins[i]; /* may be null */ -#else /* COMPILER */ pp = (struct pstrnm *)qsearch((char *)s,(char *)pntab,pnsize, sizeof(struct pstrnm),dp_pnmcmp); if (pp!=NULL) return (struct b_proc *)pp->pblock; -#endif /* !COMPILER */ return NULL; } @@ -887,13 +789,9 @@ union numeric *result; */ if (c == 'r' || c == 'R') { int rv; -#ifdef LargeInts rv = bigradix((int)msign, (int)mantissa, s, end_s, result); if (rv == Error) fatalerr(0, NULL); -#else /* LargeInts */ - rv = radix((int)msign, (int)mantissa, s, end_s, result); -#endif /* LargeInts */ return rv; } @@ -959,21 +857,16 @@ union numeric *result; return T_Integer; } -#ifdef LargeInts /* * Test for bignum. */ -#if COMPILER - if (largeints) -#endif /* COMPILER */ - if (!realflag) { - int rv; - rv = bigradix((int)msign, 10, ssave, end_s, result); - if (rv == Error) - fatalerr(0, NULL); - return rv; - } -#endif /* LargeInts */ + if (!realflag) { + int rv; + rv = bigradix((int)msign, 10, ssave, end_s, result); + if (rv == Error) + fatalerr(0, NULL); + return rv; + } if (!realflag) return CvtFail; /* don't promote to real if integer format */ @@ -1023,50 +916,6 @@ union numeric *result; result->real = mantissa; return T_Real; } - -#if COMPILER || !(defined LargeInts) -/* - * radix - convert string s in radix r into an integer in *result. sign - * will be either '+' or '-'. - */ -int radix(sign, r, s, end_s, result) -int sign; -register int r; -register char *s; -register char *end_s; -union numeric *result; - { - register int c; - long num; - - if (r < 2 || r > 36) - return CvtFail; - c = (s < end_s) ? *s++ : ' '; - num = 0L; - while (isalnum(c)) { - c = tonum(c); - if (c >= r) - return CvtFail; - num = num * r + c; - c = (s < end_s) ? *s++ : ' '; - } - - /* - * Skip trailing white space and make sure there is nothing else left - * in the string. Note, if we have already reached end-of-string, - * c has been set to a space. - */ - while (isspace(c) && s < end_s) - c = *s++; - if (!isspace(c)) - return CvtFail; - - result->integer = (sign == '+' ? num : -num); - - return T_Integer; - } -#endif /* COMPILER || !(defined LargeInts) */ - /* * cvpos - convert position to strictly positive position diff --git a/src/runtime/data.r b/src/runtime/data.r index 1a276bd..be8c169 100644 --- a/src/runtime/data.r +++ b/src/runtime/data.r @@ -2,16 +2,8 @@ * data.r -- Various interpreter data tables. */ -#if !COMPILER - struct b_proc Bnoproc; -#ifdef EventMon -struct b_iproc mt_llist = { - 6, (sizeof(struct b_proc) - sizeof(struct descrip)), Ollist, - 0, -1, 0, 0, {sizeof( "[...]")-1, "[...]"}}; -#endif /* EventMon */ - /* * External declarations for function blocks. @@ -87,7 +79,6 @@ struct pstrnm pntab[] = { int pnsize = (sizeof(pntab) / sizeof(struct pstrnm)) - 1; -#endif /* COMPILER */ /* * Structures for built-in values. Parts of some of these structures are @@ -132,8 +123,6 @@ struct b_cset fullcs = { ~0, ~0, ~0, ~0, ~0, ~0, ~0, ~0) }; -#if !COMPILER - /* * Built-in csets */ @@ -181,29 +170,17 @@ struct b_cset k_letters = { cset_display(0, 0, 0, 0, ~01, 03777, ~01, 03777, 0, 0, 0, 0, 0, 0, 0, 0) }; -#endif /* COMPILER */ /* * Built-in files. */ - -#ifndef MultiThread struct b_file k_errout = {T_File, NULL, Fs_Write}; /* &errout */ struct b_file k_input = {T_File, NULL, Fs_Read}; /* &input */ struct b_file k_output = {T_File, NULL, Fs_Write}; /* &output */ -#endif /* MultiThread */ - -#ifdef EventMon -/* - * Real block needed for event monitoring. - */ -struct b_real realzero = {T_Real, 0.0}; -#endif /* EventMon */ /* * Keyword variables. */ -#ifndef MultiThread struct descrip kywd_err = {D_Integer}; /* &error */ struct descrip kywd_pos = {D_Integer}; /* &pos */ struct descrip kywd_prog; /* &progname */ @@ -213,13 +190,6 @@ struct descrip kywd_trc = {D_Integer}; /* &trace */ struct descrip k_eventcode = {D_Null}; /* &eventcode */ struct descrip k_eventsource = {D_Null};/* &eventsource */ struct descrip k_eventvalue = {D_Null}; /* &eventvalue */ - -#endif /* MultiThread */ - -#ifdef FncTrace -struct descrip kywd_ftrc = {D_Integer}; /* &ftrace */ -#endif /* FncTrace */ - struct descrip kywd_dmp = {D_Integer}; /* &dump */ struct descrip nullptr = @@ -239,15 +209,6 @@ struct descrip onedesc = {D_Integer}; /* integer 1 */ struct descrip ucase; /* string of uppercase letters */ struct descrip zerodesc = {D_Integer}; /* integer 0 */ -#ifdef EventMon -/* - * Descriptors used by event monitoring. - */ -struct descrip csetdesc = {D_Cset}; -struct descrip eventdesc; -struct descrip rzerodesc = {D_Real}; -#endif /* EventMon */ - /* * An array of all characters for use in making one-character strings. */ @@ -303,6 +264,12 @@ struct errtab errtab[] = { 125, "list, record, or set expected", 126, "list or record expected", + /* general messages for use by code dealing with external data */ + 131, "external expected", /* not an external */ + 132, "incorrect external type", /* external of wrong flavor */ + 133, "invalid external value", /* right flavor in wrong context */ + 134, "malformed external value", /* data bogus, not just inappropriate */ + #ifdef Graphics 140, "window expected", 141, "program terminated by window manager", @@ -344,9 +311,6 @@ struct errtab errtab[] = { 307, "inadequate space in block region", 308, "system stack overflow in co-expression", -#ifndef Coexpr - 401, "co-expressions not implemented", -#endif /* Coexpr */ 402, "program not compiled with debugging option", 500, "program malfunction", /* for use by runerr() */ @@ -355,7 +319,6 @@ struct errtab errtab[] = { 0, "" }; -#if !COMPILER #define OpDef(p,n,s,u) int Cat(O,p) (dptr cargp); #include "../h/odefs.h" #undef OpDef @@ -398,4 +361,3 @@ int (*keytab[])() = { #define KDef(p,n) Cat(K,p), #include "../h/kdefs.h" }; -#endif /* !COMPILER */ diff --git a/src/runtime/errmsg.r b/src/runtime/errmsg.r index 7095781..03d558a 100644 --- a/src/runtime/errmsg.r +++ b/src/runtime/errmsg.r @@ -38,18 +38,11 @@ dptr v; break; } - EVVal((word)k_errornumber,E_Error); - if (pfp != NULL) { if (IntVal(kywd_err) == 0 || !err_conv) { fprintf(stderr, "\nRun-time error %d\n", k_errornumber); -#if COMPILER - if (line_info) - fprintf(stderr, "File %s; Line %d\n", file_name, line_num); -#else /* COMPILER */ fprintf(stderr, "File %s; Line %ld\n", findfile(ipc.opnd), (long)findline(ipc.opnd)); -#endif /* COMPILER */ } else { IntVal(kywd_err)--; diff --git a/src/runtime/extcall.r b/src/runtime/extcall.r deleted file mode 100644 index 5652416..0000000 --- a/src/runtime/extcall.r +++ /dev/null @@ -1,21 +0,0 @@ -/* - * extcall.r - */ - -#if !COMPILER -#ifdef ExternalFunctions - -/* - * extcall - stub procedure for external call interface. - */ -dptr extcall(dargv, argc, ip) -dptr dargv; -int argc; -int *ip; - { - *ip = 216; /* no external function to find */ - return (dptr)NULL; - } - -#endif /* ExternalFunctions */ -#endif /* !COMPILER */ diff --git a/src/runtime/fconv.r b/src/runtime/fconv.r index 7c3a3ff..d458062 100644 --- a/src/runtime/fconv.r +++ b/src/runtime/fconv.r @@ -22,24 +22,17 @@ function{1} abs(n) else { i = neg(n); if (over_flow) { -#ifdef LargeInts struct descrip tmp; MakeInt(n,&tmp); if (bigneg(&tmp, &result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - irunerr(203,n); - errorfail; -#endif /* LargeInts */ } } return C_integer i; } } - -#ifdef LargeInts else if cnv:(exact)integer(n) then { abstract { return integer @@ -54,7 +47,6 @@ function{1} abs(n) return result; } } -#endif /* LargeInts */ else if cnv:C_double(n) then { abstract { @@ -140,55 +132,13 @@ end "proc(x,i) - convert x to a procedure if possible; use i to resolve " "ambiguous string names." -#ifdef MultiThread -function{0,1} proc(x,i,c) -#else /* MultiThread */ function{0,1} proc(x,i) -#endif /* MultiThread */ - -#ifdef MultiThread - if is:coexpr(x) then { - abstract { - return proc - } - inline { - struct b_coexpr *ce = NULL; - struct b_proc *bp = NULL; - struct pf_marker *fp; - dptr dp=NULL; - if (BlkLoc(x) != BlkLoc(k_current)) { - ce = (struct b_coexpr *)BlkLoc(x); - dp = ce->es_argp; - if (dp == NULL) fail; - bp = (struct b_proc *)BlkLoc(*(dp)); - } - else - bp = (struct b_proc *)BlkLoc(*(glbl_argp)); - return proc(bp); - } - } -#endif /* MultiThread */ if is:proc(x) then { abstract { return proc } inline { - -#ifdef MultiThread - if (!is:null(c)) { - struct progstate *p; - if (!is:coexpr(c)) runerr(118,c); - /* - * Test to see whether a given procedure belongs to a given - * program. Currently this is a sleazy pointer arithmetic check. - */ - p = BlkLoc(c)->coexpr.program; - if (! InRange(p, BlkLoc(x)->proc.entryp.icode, - (char *)p + p->hsize)) - fail; - } -#endif /* MultiThread */ return x; } } @@ -212,23 +162,6 @@ function{0,1} proc(x,i) inline { struct b_proc *prc; -#ifdef MultiThread - struct progstate *prog, *savedprog; - - savedprog = curpstate; - if (is:null(c)) { - prog = curpstate; - } - else if (is:coexpr(c)) { - prog = BlkLoc(c)->coexpr.program; - } - else { - runerr(118,c); - } - - ENTERPSTATE(prog); -#endif /* MultiThread */ - /* * Attempt to convert Arg0 to a procedure descriptor using i to * discriminate between procedures with the same names. If i @@ -240,9 +173,6 @@ function{0,1} proc(x,i) else prc = strprc(&x, i); -#ifdef MultiThread - ENTERPSTATE(savedprog); -#endif /* MultiThread */ if (prc == NULL) fail; else diff --git a/src/runtime/fload.r b/src/runtime/fload.r index dfb9fcc..e972002 100644 --- a/src/runtime/fload.r +++ b/src/runtime/fload.r @@ -22,24 +22,6 @@ #define RTLD_LAZY 1 #endif /* RTLD_LAZY */ -#ifdef FreeBSD - /* - * If DL_GETERRNO exists, this is an FreeBSD 1.1.5 or 2.0 - * which lacks dlerror(); supply a substitute. - */ - #passthru #ifdef DL_GETERRNO - char *dlerror(void) - { - int no; - - if (0 == dlctl(NULL, DL_GETERRNO, &no)) - return(strerror(no)); - else - return(NULL); - } - #passthru #endif -#endif /* __FreeBSD__ */ - int glue(); int makefunc (dptr d, char *name, int (*func)()); @@ -69,7 +51,7 @@ function{0,1} loadfunc(filename,funcname) if (curfile) free((pointer)curfile); /* free the old file name */ curfile = salloc(filename); /* save the new name */ - handle = dlopen(filename, RTLD_LAZY); /* get the handle */ + handle = dlopen(filename, RTLD_LAZY | RTLD_GLOBAL); /* get handle */ } /* * Load the function. Diagnose both library and function errors here. @@ -121,12 +103,7 @@ int (*func)(); return 0; blk->title = T_Proc; blk->blksize = sizeof(struct b_proc); - -#if COMPILER - blk->ccode = glue; /* set code addr to glue routine */ -#else /* COMPILER */ blk->entryp.ccode = glue; /* set code addr to glue routine */ -#endif /* COMPILER */ blk->nparam = -1; /* varargs flag */ blk->ndynam = -1; /* treat as built-in function */ @@ -147,47 +124,6 @@ int (*func)(); * It digs the actual C code address out of the proc block, and calls that. */ -#if COMPILER - -int glue(argc, dargv, rslt, succ_cont) -int argc; -dptr dargv; -dptr rslt; -continuation succ_cont; - { - int i, status, (*func)(); - struct b_proc *blk; - struct descrip r; - tended struct descrip p; - - dargv--; /* reset pointer to proc entry */ - for (i = 0; i <= argc; i++) - deref(&dargv[i], &dargv[i]); /* dereference args including proc */ - - blk = (struct b_proc *)dargv[0].vword.bptr; /* proc block address */ - func = (int (*)())blk->lnames[0].vword.sptr; /* entry point address */ - - p = dargv[0]; /* save proc for traceback */ - dargv[0] = nulldesc; /* set default return value */ - status = (*func)(argc, dargv); /* call func */ - - if (status == 0) { - *rslt = dargv[0]; - Return; /* success */ - } - - if (status < 0) - Fail; /* failure */ - - r = dargv[0]; /* save result value */ - dargv[0] = p; /* restore proc for traceback */ - if (is:null(r)) - RunErr(status, NULL); /* error, no value */ - RunErr(status, &r); /* error, with value */ - } - -#else /* COMPILER */ - int glue(argc, dargv) int argc; dptr dargv; @@ -216,6 +152,4 @@ dptr dargv; RunErr(status, &r); /* error, with value */ } -#endif /* COMPILER */ - #endif /* LoadFunc */ diff --git a/src/runtime/fmisc.r b/src/runtime/fmisc.r index 6691241..2c4474d 100644 --- a/src/runtime/fmisc.r +++ b/src/runtime/fmisc.r @@ -5,9 +5,7 @@ * ishift, ixor, [keyword], [load], ord, name, runerr, seq, sort, sortf, * type, variable */ -#if !COMPILER #include "../h/opdefs.h" -#endif /* !COMPILER */ "args(p) - produce number of arguments for procedure p." @@ -24,53 +22,6 @@ function{1} args(x) } end -#if !COMPILER -#ifdef ExternalFunctions - -/* - * callout - call a C library routine (or any C routine that doesn't call Icon) - * with an argument count and a list of descriptors. This routine - * doesn't build a procedure frame to prepare for calling Icon back. - */ -function{1} callout(x[nargs]) - body { - dptr retval; - int signal; - - /* - * Little cheat here. Although this is a var-arg procedure, we need - * at least one argument to get started: pretend there is a null on - * the stack. NOTE: Actually, at present, varargs functions always - * have at least one argument, so this doesn't plug the hole. - */ - if (nargs < 1) - runerr(103, nulldesc); - - /* - * Call the 'C routine caller' with a pointer to an array of descriptors. - * Note that these are being left on the stack. We are passing - * the name of the routine as part of the convention of calling - * routines with an argc/argv technique. - */ - signal = -1; /* presume successful completiong */ - retval = extcall(x, nargs, &signal); - if (signal >= 0) { - if (retval == NULL) - runerr(signal); - else - runerr(signal, *retval); - } - if (retval != NULL) { - return *retval; - } - else - fail; - } -end - -#endif /* ExternalFunctions */ -#endif /* !COMPILER */ - "char(i) - produce a string consisting of character i." @@ -174,11 +125,6 @@ function{1} copy(x) } table: { body { -#ifdef TableFix - if (cptable(&x, &result, BlkLoc(x)->table.size) == Error) - runerr(0); - return result; -#else /* TableFix */ register int i; register word slotnum; tended union block *src; @@ -195,7 +141,10 @@ function{1} copy(x) runerr(0); dst->table.size = src->table.size; dst->table.mask = src->table.mask; - dst->table.defvalue = src->table.defvalue; + /* dst->table.defvalue = src->table.defvalue; */ + /* to avoid gcc 4.2.2 bug on Sparc, do instead: */ + memcpy(&dst->table.defvalue, &src->table.defvalue, + sizeof(struct descrip)); for (i = 0; i < HSegs && src->table.hdir[i] != NULL; i++) memcpy((char *)dst->table.hdir[i], (char *)src->table.hdir[i], src->table.hdir[i]->blksize); @@ -221,9 +170,7 @@ function{1} copy(x) if (TooSparse(dst)) hshrink(dst); - Desc_EVValD(dst, E_Tcreate, D_Table); return table(dst); -#endif /* TableFix */ } } @@ -262,14 +209,17 @@ function{1} copy(x) d2 = old_rec->fields; while (i--) *d1++ = *d2++; - Desc_EVValD(new_rec, E_Rcreate, D_Record); return record(new_rec); } } - default: body { - runerr(123,x); - } + default: + body { + if (Type(x) == T_External) + return callextfunc(&extlcopy, &x, NULL); + else + runerr(123,x); + } } end @@ -278,15 +228,7 @@ end " procedure activations, plus global variables." " Output to file f (default &errout)." -#ifdef MultiThread -function{1} display(i,f,c) - declare { - struct b_coexpr *ce = NULL; - struct progstate *prog, *savedprog; - } -#else /* MultiThread */ function{1} display(i,f) -#endif /* MultiThread */ if !def:C_integer(i,(C_integer)k_level) then runerr(101, i) @@ -299,15 +241,6 @@ function{1} display(i,f) else if !is:file(f) then runerr(105, f) -#ifdef MultiThread - if !is:null(c) then inline { - if (!is:coexpr(c)) runerr(118,c); - else if (BlkLoc(c) != BlkLoc(k_current)) - ce = (struct b_coexpr *)BlkLoc(c); - savedprog = curpstate; - } -#endif /* MultiThread */ - abstract { return null } @@ -340,16 +273,7 @@ function{1} display(i,f) (long)BlkLoc(k_current)->coexpr.id, (long)BlkLoc(k_current)->coexpr.size); fflush(std_f); -#ifdef MultiThread - if (ce) { - if ((ce->es_pfp == NULL) || (ce->es_argp == NULL)) fail; - ENTERPSTATE(ce->program); - r = xdisp(ce->es_pfp, ce->es_argp, (int)i, std_f); - ENTERPSTATE(savedprog); - } - else -#endif /* MultiThread */ - r = xdisp(pfp, glbl_argp, (int)i, std_f); + r = xdisp(pfp, glbl_argp, (int)i, std_f); if (r == Failed) runerr(305); return nulldesc; @@ -372,7 +296,6 @@ function{1} errorclear() } end -#if !COMPILER "function() - generate the names of the functions." @@ -389,7 +312,6 @@ function{*} function() fail; } end -#endif /* !COMPILER */ /* @@ -412,13 +334,11 @@ function{1} func_name(i,j) return integer } inline { -#ifdef LargeInts if ((Type(i)==T_Lrgint) || (Type(j)==T_Lrgint)) { big_ ## c_op(i,j); } else -#endif /* LargeInts */ - return C_integer IntVal(i) c_op IntVal(j); + return C_integer IntVal(i) c_op IntVal(j); } end #enddef @@ -466,7 +386,6 @@ function{1} icom(i) return integer } inline { -#ifdef LargeInts if (Type(i) == T_Lrgint) { struct descrip td; @@ -477,8 +396,7 @@ function{1} icom(i) return result; } else -#endif /* LargeInts */ - return C_integer ~IntVal(i); + return C_integer ~IntVal(i); } end @@ -514,7 +432,6 @@ function{1} ishift(i,j) body { uword ci; /* shift in 0s, even if negative */ C_integer cj; -#ifdef LargeInts if (Type(j) == T_Lrgint) runerr(101,j); cj = IntVal(j); @@ -524,10 +441,6 @@ function{1} ishift(i,j) runerr(0); return result; } -#else /* LargeInts */ - ci = (uword)IntVal(i); - cj = IntVal(j); -#endif /* LargeInts */ /* * Check for a shift of WordSize or greater; handle specially because * this is beyond C's defined behavior. Otherwise shift as requested. @@ -564,14 +477,7 @@ end "name(v) - return the name of a variable." -#ifdef MultiThread -function{1} name(underef v, c) - declare { - struct progstate *prog, *savedprog; - } -#else /* MultiThread */ function{1} name(underef v) -#endif /* MultiThread */ /* * v must be a variable */ @@ -586,27 +492,7 @@ function{1} name(underef v) C_integer i; if (!debug_info) runerr(402); - -#ifdef MultiThread - savedprog = curpstate; - if (is:null(c)) { - prog = curpstate; - } - else if (is:coexpr(c)) { - prog = BlkLoc(c)->coexpr.program; - } - else { - runerr(118,c); - } - - ENTERPSTATE(prog); -#endif /* MultiThread */ i = get_name(&v, &result); /* return val ? #%#% */ - -#ifdef MultiThread - ENTERPSTATE(savedprog); -#endif /* MultiThread */ - if (i == Error) runerr(0); return result; @@ -672,7 +558,6 @@ function{1,*} seq(from, by) } while (from >= seq_lb && from <= seq_ub); -#if !COMPILER { /* * Suspending wipes out some things needed by the trace back code to @@ -684,7 +569,6 @@ function{1,*} seq(from, by) r_args[0].dword = D_Proc; r_args[0].vword.bptr = (union block *)&Bseq; } -#endif /* COMPILER */ runerr(203); } @@ -724,8 +608,12 @@ function {0,1} serial(x) } } #endif /* Graphics */ - default: - inline { fail; } + default: inline { + if (Type(x) == T_External) + return C_integer BlkLoc(x)->externl.id; + else + fail; + } } end @@ -750,7 +638,6 @@ function{1} sort(t, i) qsort((char *)BlkLoc(result)->list.listhead->lelem.lslots, (int)size, sizeof(struct descrip), (int (*)()) anycmp); - Desc_EVValD(BlkLoc(result), E_Lcreate, D_List); return result; } } @@ -775,9 +662,6 @@ function{1} sort(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); lp->listhead = lp->listtail = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *) lp; -#endif /* ListFix */ bp = BlkLoc(t); /* need not be tended if not set until now */ if (size > 0) { /* only need to sort non-empty records */ @@ -788,7 +672,6 @@ function{1} sort(t, i) sizeof(struct descrip), (int (*)())anycmp); } - Desc_EVValD(lp, E_Lcreate, D_List); return list(lp); } } @@ -814,9 +697,6 @@ function{1} sort(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); lp->listhead = lp->listtail = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *)lp; -#endif /* ListFix */ bp = BlkLoc(t); /* need not be tended if not set until now */ if (size > 0) { /* only need to sort non-empty sets */ @@ -829,7 +709,6 @@ function{1} sort(t, i) sizeof(struct descrip), (int (*)())anycmp); } - Desc_EVValD(lp, E_Lcreate, D_List); return list(lp); } } @@ -883,9 +762,6 @@ function{1} sort(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep=(union block *)alclstb(size,(word)0,size),runerr(0)); lp->listtail = lp->listhead = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *) lp; -#endif /* ListFix */ /* * If the table is empty, there is no need to sort anything. */ @@ -904,20 +780,12 @@ function{1} sort(t, i) for (j = 0; j < HSegs && (seg = bp->hdir[j]) != NULL; j++) for (k = segsize[j] - 1; k >= 0; k--) for (ep= seg->hslots[k]; -#ifdef TableFix - BlkType(ep) == T_Telem; -#else /* TableFix */ ep != NULL; -#endif /* TableFix */ ep = ep->telem.clink){ Protect(tp = alclist((word)2), runerr(0)); Protect(ev = (union block *)alclstb((word)2, (word)0, (word)2), runerr(0)); tp->listhead = tp->listtail = ev; -#ifdef ListFix - ev->lelem.listprev = ev->lelem.listnext = - (union block *)tp; -#endif /* ListFix */ tp->listhead->lelem.lslots[0] = ep->telem.tref; tp->listhead->lelem.lslots[1] = ep->telem.tval; d1 = &lp->listhead->lelem.lslots[n++]; @@ -958,9 +826,6 @@ function{1} sort(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); lp->listhead = lp->listtail = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *)lp; -#endif /* ListFix */ /* * If the table is empty there's no need to sort anything. */ @@ -983,11 +848,7 @@ function{1} sort(t, i) for (j = 0; j < HSegs && (seg = bp->hdir[j]) != NULL; j++) for (k = segsize[j] - 1; k >= 0; k--) for (ep = seg->hslots[k]; -#ifdef TableFix - BlkType(ep) == T_Telem; -#else /* TableFix */ ep != NULL; -#endif /* TableFix */ ep = ep->telem.clink) { *d1++ = ep->telem.tref; *d1++ = ep->telem.tval; @@ -1016,7 +877,6 @@ function{1} sort(t, i) * Make result point at the sorted list. */ - Desc_EVValD(lp, E_Lcreate, D_List); return list(lp); } } @@ -1033,12 +893,6 @@ end int trefcmp(d1,d2) dptr d1, d2; { - -#ifdef DeBug - if (d1->dword != D_List || d2->dword != D_List) - syserr("trefcmp: internal consistency check fails."); -#endif /* DeBug */ - return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[0]), &(BlkLoc(*d2)->list.listhead->lelem.lslots[0]))); } @@ -1050,12 +904,6 @@ dptr d1, d2; int tvalcmp(d1,d2) dptr d1, d2; { - -#ifdef DeBug - if (d1->dword != D_List || d2->dword != D_List) - syserr("tvalcmp: internal consistency check fails."); -#endif /* DeBug */ - return (anycmp(&(BlkLoc(*d1)->list.listhead->lelem.lslots[1]), &(BlkLoc(*d2)->list.listhead->lelem.lslots[1]))); } @@ -1113,7 +961,6 @@ function{1} sortf(t, i) qsort((char *)BlkLoc(result)->list.listhead->lelem.lslots, (int)size, sizeof(struct descrip), (int (*)()) nthcmp); - Desc_EVValD(BlkLoc(result), E_Lcreate, D_List); return result; } } @@ -1146,9 +993,6 @@ function{1} sortf(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); lp->listhead = lp->listtail = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *) lp; -#endif /* ListFix */ bp = BlkLoc(t); /* need not be tended if not set until now */ if (size > 0) { /* only need to sort non-empty records */ @@ -1160,7 +1004,6 @@ function{1} sortf(t, i) sizeof(struct descrip), (int (*)())nthcmp); } - Desc_EVValD(lp, E_Lcreate, D_List); return list(lp); } } @@ -1194,9 +1037,6 @@ function{1} sortf(t, i) Protect(lp = alclist(size), runerr(0)); Protect(ep = (union block *)alclstb(size,(word)0,size), runerr(0)); lp->listhead = lp->listtail = ep; -#ifdef ListFix - ep->lelem.listprev = ep->lelem.listnext = (union block *)lp; -#endif /* ListFix */ bp = BlkLoc(t); /* need not be tended if not set until now */ if (size > 0) { /* only need to sort non-empty sets */ @@ -1210,7 +1050,6 @@ function{1} sortf(t, i) sizeof(struct descrip), (int (*)())nthcmp); } - Desc_EVValD(lp, E_Lcreate, D_List); return list(lp); } } @@ -1337,12 +1176,9 @@ function{1} type(x) coexpr: inline { return C_string "co-expression"; } default: inline { -#if !COMPILER - if (!Qual(x) && (Type(x)==T_External)) { - return C_string "external"; - } + if (!Qual(x) && (Type(x) == T_External)) + return callextfunc(&extlname, &x, NULL); else -#endif /* !COMPILER */ runerr(123,x); } } @@ -1352,853 +1188,20 @@ end "variable(s) - find the variable with name s and return a" " variable descriptor which points to its value." -#ifdef MultiThread -function{0,1} variable(s,c,i) -#else /* MultiThread */ function{0,1} variable(s) -#endif /* MultiThread */ - if !cnv:C_string(s) then runerr(103, s) -#ifdef MultiThread - if !def:C_integer(i,0) then - runerr(101,i) -#endif /* MultiThread */ - abstract { return variable } body { register int rv; - -#ifdef MultiThread - struct progstate *prog, *savedprog; - struct pf_marker *tmp_pfp = pfp; - dptr tmp_argp = glbl_argp; - - savedprog = curpstate; - if (!is:null(c)) { - if (is:coexpr(c)) { - prog = BlkLoc(c)->coexpr.program; - pfp = BlkLoc(c)->coexpr.es_pfp; - glbl_argp = BlkLoc(c)->coexpr.es_argp; - ENTERPSTATE(prog); - } - else { - runerr(118, c); - } - } - - /* - * Produce error if i is negative - */ - if (i < 0) { - irunerr(205, i); - errorfail; - } - - while (i--) { - if (pfp == NULL) fail; - glbl_argp = pfp->pf_argp; - pfp = pfp->pf_pfp; - } -#endif /* MultiThread */ - rv = getvar(s, &result); - -#ifdef MultiThread - if (is:coexpr(c)) { - ENTERPSTATE(savedprog); - pfp = tmp_pfp; - glbl_argp = tmp_argp; - - if ((rv == LocalName) || (rv == StaticName)) { - Deref(result); - } - } -#endif /* MultiThread */ - if (rv != Failed) return result; else fail; } end - -#ifdef MultiThread - -"cofail(CE) - transmit a co-expression failure to CE" - -function{0,1} cofail(CE) - abstract { - return any_value - } - if is:null(CE) then - body { - struct b_coexpr *ce = topact((struct b_coexpr *)BlkLoc(k_current)); - if (ce != NULL) { - CE.dword = D_Coexpr; - BlkLoc(CE) = (union block *)ce; - } - else runerr(118,CE); - } - else if !is:coexpr(CE) then - runerr(118,CE) - body { - struct b_coexpr *ncp = (struct b_coexpr *)BlkLoc(CE); - if (co_chng(ncp, NULL, &result, A_Cofail, 1) == A_Cofail) fail; - return result; - } -end - - -"fieldnames(r) - generate the fieldnames of record r" - -function{*} fieldnames(r) - abstract { - return string - } - if !is:record(r) then runerr(107,r) - body { - int i; - for(i=0;i<BlkLoc(r)->record.recdesc->proc.nfields;i++) { - suspend BlkLoc(r)->record.recdesc->proc.lnames[i]; - } - fail; - } -end - - -"localnames(ce,i) - produce the names of local variables" -" in the procedure activation i levels up in ce" -function{*} localnames(ce,i) - declare { - tended struct descrip d; - } - abstract { - return string - } - if is:null(ce) then inline { - d = k_current; - BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else if is:proc(ce) then inline { - int j; - struct b_proc *cproc = (struct b_proc *)BlkLoc(ce); - for(j = 0; j < cproc->ndynam; j++) { - result = cproc->lnames[j + cproc->nparam]; - suspend result; - } - fail; - } - else if is:coexpr(ce) then inline { - d = ce; - BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else runerr(118, ce) - if !def:C_integer(i,0) then - runerr(101,i) - body { -#if !COMPILER - int j; - dptr arg; - struct b_proc *cproc; - struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp; - - if (thePfp == NULL) fail; - - /* - * Produce error if i is negative - */ - if (i < 0) { - irunerr(205, i); - errorfail; - } - - while (i--) { - thePfp = thePfp->pf_pfp; - if (thePfp == NULL) fail; - } - - arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1]; - cproc = (struct b_proc *)BlkLoc(arg[0]); - for(j = 0; j < cproc->ndynam; j++) { - result = cproc->lnames[j + cproc->nparam]; - suspend result; - } -#endif /* !COMPILER */ - fail; - } -end - - - -"staticnames(ce,i) - produce the names of static variables" -" in the current procedure activation in ce" - -function{*} staticnames(ce,i) - declare { - tended struct descrip d; - } - abstract { - return string - } - if is:null(ce) then inline { - d = k_current; - BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else if is:proc(ce) then inline { - int j; - struct b_proc *cproc = (struct b_proc *)BlkLoc(ce); - for(j = 0; j < cproc->nstatic; j++) { - result = cproc->lnames[j + cproc->nparam + cproc->ndynam]; - suspend result; - } - fail; - } - else if is:coexpr(ce) then inline { - d = ce; - BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else runerr(118,ce) - if !def:C_integer(i,0) then - runerr(101,i) - body { -#if !COMPILER - int j; - dptr arg; - struct b_proc *cproc; - struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp; - if (thePfp == NULL) fail; - - /* - * Produce error if i is negative - */ - if (i < 0) { - irunerr(205, i); - errorfail; - } - - while (i--) { - thePfp = thePfp->pf_pfp; - if (thePfp == NULL) fail; - } - - arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1]; - cproc = (struct b_proc *)BlkLoc(arg[0]); - for(j=0; j < cproc->nstatic; j++) { - result = cproc->lnames[j + cproc->nparam + cproc->ndynam]; - suspend result; - } -#endif /* !COMPILER */ - fail; - } -end - -"paramnames(ce,i) - produce the names of the parameters" -" in the current procedure activation in ce" - -function{1,*} paramnames(ce,i) - declare { - tended struct descrip d; - } - abstract { - return string - } - if is:null(ce) then inline { - d = k_main; - BlkLoc(k_main)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else if is:proc(ce) then inline { - int j; - struct b_proc *cproc = (struct b_proc *)BlkLoc(ce); - for(j = 0; j < cproc->nparam; j++) { - result = cproc->lnames[j]; - suspend result; - } - fail; - } - else if is:coexpr(ce) then inline { - d = ce; - BlkLoc(k_main)->coexpr.es_pfp = pfp; /* sync w/ current value */ - } - else runerr(118,ce) - if !def:C_integer(i,0) then - runerr(101,i) - body { -#if !COMPILER - int j; - dptr arg; - struct b_proc *cproc; - struct pf_marker *thePfp = BlkLoc(d)->coexpr.es_pfp; - - if (thePfp == NULL) fail; - - /* - * Produce error if i is negative - */ - if (i < 0) { - irunerr(205, i); - errorfail; - } - - while (i--) { - thePfp = thePfp->pf_pfp; - if (thePfp == NULL) fail; - } - - arg = &((dptr)thePfp)[-(thePfp->pf_nargs) - 1]; - cproc = (struct b_proc *)BlkLoc(arg[0]); - for(j = 0; j < cproc->nparam; j++) { - result = cproc->lnames[j]; - suspend result; - } -#endif /* !COMPILER */ - fail; - } -end - - -"load(s,arglist,input,output,error,blocksize,stringsize,stacksize) - load" -" an icode file corresponding to string s as a co-expression." - -function{1} load(s,arglist,infile,outfile,errfile, - blocksize, stringsize, stacksize) - declare { - tended char *loadstring; - C_integer _bs_, _ss_, _stk_; - } - if !cnv:C_string(s,loadstring) then - runerr(103,s) - if !def:C_integer(blocksize,abrsize,_bs_) then - runerr(101,blocksize) - if !def:C_integer(stringsize,ssize,_ss_) then - runerr(101,stringsize) - if !def:C_integer(stacksize,mstksize,_stk_) then - runerr(101,stacksize) - abstract { - return coexpr - } - body { - word *stack; - struct progstate *pstate; - char sbuf1[MaxCvtLen], sbuf2[MaxCvtLen]; - register struct b_coexpr *sblkp; - register struct b_refresh *rblkp; - struct ef_marker *newefp; - register dptr dp, ndp, dsp; - register word *newsp, *savedsp; - int na, nl, i, j, num_fileargs = 0; - struct b_file *theInput = NULL, *theOutput = NULL, *theError = NULL; - struct b_proc *cproc; - extern char *prog_name; - - /* - * Fragments of pseudo-icode to get loaded programs started, - * and to handle termination. - */ - static word pstart[7]; - static word *lterm; - - inst tipc; - - tipc.opnd = pstart; - *tipc.op++ = Op_Noop; /* aligns Invokes operand */ /* ?cj? */ - *tipc.op++ = Op_Invoke; - *tipc.opnd++ = 1; - *tipc.op++ = Op_Coret; - *tipc.op++ = Op_Efail; - - lterm = (word *)(tipc.op); - - *tipc.op++ = Op_Cofail; - *tipc.op++ = Op_Agoto; - *tipc.opnd = (word)lterm; - - prog_name = loadstring; /* set up for &progname */ - - /* - * arglist must be a list - */ - if (!is:null(arglist) && !is:list(arglist)) - runerr(108,arglist); - - /* - * input, output, and error must be files - */ - if (is:null(infile)) - theInput = &(curpstate->K_input); - else { - if (!is:file(infile)) - runerr(105,infile); - else theInput = &(BlkLoc(infile)->file); - } - if (is:null(outfile)) - theOutput = &(curpstate->K_output); - else { - if (!is:file(outfile)) - runerr(105,outfile); - else theOutput = &(BlkLoc(outfile)->file); - } - if (is:null(errfile)) - theError = &(curpstate->K_errout); - else { - if (!is:file(errfile)) - runerr(105,errfile); - else theError = &(BlkLoc(errfile)->file); - } - - stack = - (word *)(sblkp = loadicode(loadstring,theInput,theOutput,theError, - _bs_,_ss_,_stk_)); - if(!stack) { - fail; - } - pstate = sblkp->program; - pstate->parent = curpstate; - pstate->parentdesc = k_main; - - savedsp = sp; - sp = stack + Wsizeof(struct b_coexpr) - + Wsizeof(struct progstate) + pstate->hsize/WordSize; - if (pstate->hsize % WordSize) sp++; - -#ifdef UpStack - sblkp->cstate[0] = - ((word)((char *)sblkp + (mstksize - (sizeof(*sblkp)+sizeof(struct progstate)+pstate->hsize))/2) - &~((word)WordSize*StackAlign-1)); -#else /* UpStack */ - sblkp->cstate[0] = - ((word)((char *)sblkp + mstksize - WordSize + sizeof(struct progstate) + pstate->hsize) - &~((word)WordSize*StackAlign-1)); -#endif /* UpStack */ - - sblkp->es_argp = NULL; - sblkp->es_gfp = NULL; - pstate->Mainhead->freshblk = nulldesc;/* &main has no refresh block. */ - /* This really is a bug. */ - - /* - * Set up expression frame marker to contain execution of the - * main procedure. If failure occurs in this context, control - * is transferred to lterm, the address of an ... - */ - newefp = (struct ef_marker *)(sp+1); -#if IntBits != WordBits - newefp->ef_failure.op = (int *)lterm; -#else /* IntBits != WordBits */ - newefp->ef_failure.op = lterm; -#endif /* IntBits != WordBits */ - - newefp->ef_gfp = 0; - newefp->ef_efp = 0; - newefp->ef_ilevel = ilevel/*1*/; - sp += Wsizeof(*newefp) - 1; - sblkp->es_efp = newefp; - - /* - * The first global variable holds the value of "main". If it - * is not of type procedure, this is noted as run-time error 117. - * Otherwise, this value is pushed on the stack. - */ - if (pstate->Globals[0].dword != D_Proc) - fatalerr(117, NULL); - - PushDesc(pstate->Globals[0]); - - /* - * Create a list from arguments using Ollist and push a descriptor - * onto new stack. Then create procedure frame on new stack. Push - * two new null descriptors, and set sblkp->es_sp when all finished. - */ - if (!is:null(arglist)) { - PushDesc(arglist); - pstate->Glbl_argp = (dptr)(sp - 1); - } - else { - PushNull; - pstate->Glbl_argp = (dptr)(sp - 1); - { - dptr tmpargp = (dptr) (sp - 1); - Ollist(0, tmpargp); - sp = (word *)tmpargp + 1; - } - } - sblkp->es_sp = (word *)sp; - sblkp->es_ipc.opnd = pstart; - - result.dword = D_Coexpr; - BlkLoc(result) = (union block *)sblkp; - sp = savedsp; - return result; - } -end - - -"parent(ce) - given a ce, return &main for that ce's parent" - -function{1} parent(ce) - if is:null(ce) then inline { ce = k_current; } - else if !is:coexpr(ce) then runerr(118,ce) - abstract { - return coexpr - } - body { - if (BlkLoc(ce)->coexpr.program->parent == NULL) fail; - - result.dword = D_Coexpr; - BlkLoc(result) = - (union block *)(BlkLoc(ce)->coexpr.program->parent->Mainhead); - return result; - } -end - -#ifdef EventMon - -"eventmask(ce,cs) - given a ce, get or set that program's event mask" - -function{1} eventmask(ce,cs) - if !is:coexpr(ce) then runerr(118,ce) - - if is:null(cs) then { - abstract { - return cset++null - } - body { - result = BlkLoc(ce)->coexpr.program->eventmask; - return result; - } - } - else if !cnv:cset(cs) then runerr(104,cs) - else { - abstract { - return cset - } - body { - ((struct b_coexpr *)BlkLoc(ce))->program->eventmask = cs; - return cs; - } - } -end -#endif /* EventMon */ - - -"globalnames(ce) - produce the names of identifiers global to ce" - -function{*} globalnames(ce) - declare { - struct progstate *ps; - } - abstract { - return string - } - if is:null(ce) then inline { ps = curpstate; } - else if is:coexpr(ce) then - inline { ps = BlkLoc(ce)->coexpr.program; } - else runerr(118,ce) - body { - struct descrip *dp; - for (dp = ps->Gnames; dp != ps->Egnames; dp++) { - suspend *dp; - } - fail; - } -end - -"keyword(kname,ce) - produce a keyword in ce's thread" -function{*} keyword(keyname,ce) - declare { - tended struct descrip d; - tended char *kyname; - } - abstract { - return any_value - } - if !cnv:C_string(keyname,kyname) then runerr(103,keyname) - if is:null(ce) then inline { - d = k_current; - BlkLoc(k_current)->coexpr.es_pfp = pfp; /* sync w/ current value */ - BlkLoc(k_current)->coexpr.es_ipc.opnd = ipc.opnd; - } - else if is:coexpr(ce) then - inline { d = ce; } - else runerr(118, ce) - body { - struct progstate *p = BlkLoc(d)->coexpr.program; - char *kname = kyname; - if (kname[0] == '&') kname++; - if (strcmp(kname,"allocated") == 0) { - suspend C_integer stattotal + p->stringtotal + p->blocktotal; - suspend C_integer stattotal; - suspend C_integer p->stringtotal; - return C_integer p->blocktotal; - } - else if (strcmp(kname,"collections") == 0) { - suspend C_integer p->colltot; - suspend C_integer p->collstat; - suspend C_integer p->collstr; - return C_integer p->collblk; - } - else if (strcmp(kname,"column") == 0) { - struct progstate *savedp = curpstate; - int i; - ENTERPSTATE(p); - i = findcol(BlkLoc(d)->coexpr.es_ipc.opnd); - ENTERPSTATE(savedp); - return C_integer i; - } - else if (strcmp(kname,"current") == 0) { - return p->K_current; - } - else if (strcmp(kname,"error") == 0) { - return kywdint(&(p->Kywd_err)); - } - else if (strcmp(kname,"errornumber") == 0) { - return C_integer p->K_errornumber; - } - else if (strcmp(kname,"errortext") == 0) { - return C_string p->K_errortext; - } - else if (strcmp(kname,"errorvalue") == 0) { - return p->K_errorvalue; - } - else if (strcmp(kname,"errout") == 0) { - return file(&(p->K_errout)); - } - else if (strcmp(kname,"eventcode") == 0) { - return kywdevent(&(p->eventcode)); - } - else if (strcmp(kname,"eventsource") == 0) { - return kywdevent(&(p->eventsource)); - } - else if (strcmp(kname,"eventvalue") == 0) { - return kywdevent(&(p->eventval)); - } - else if (strcmp(kname,"file") == 0) { - struct progstate *savedp = curpstate; - struct descrip s; - ENTERPSTATE(p); - StrLoc(s) = findfile(BlkLoc(d)->coexpr.es_ipc.opnd); - StrLen(s) = strlen(StrLoc(s)); - ENTERPSTATE(savedp); - if (!strcmp(StrLoc(s),"?")) fail; - return s; - } - else if (strcmp(kname,"input") == 0) { - return file(&(p->K_input)); - } - else if (strcmp(kname,"level") == 0) { - /* - * Bug; levels aren't maintained per program yet. - * But shouldn't they be per co-expression, not per program? - */ - } - else if (strcmp(kname,"line") == 0) { - struct progstate *savedp = curpstate; - int i; - ENTERPSTATE(p); - i = findline(BlkLoc(d)->coexpr.es_ipc.opnd); - ENTERPSTATE(savedp); - return C_integer i; - } - else if (strcmp(kname,"main") == 0) { - return p->K_main; - } - else if (strcmp(kname,"output") == 0) { - return file(&(p->K_output)); - } - else if (strcmp(kname,"pos") == 0) { - return kywdpos(&(p->Kywd_pos)); - } - else if (strcmp(kname,"progname") == 0) { - return kywdstr(&(p->Kywd_prog)); - } - else if (strcmp(kname,"random") == 0) { - return kywdint(&(p->Kywd_ran)); - } - else if (strcmp(kname,"regions") == 0) { - word allRegions = 0; - struct region *rp; - - suspend C_integer 0; - for (rp = p->stringregion; rp; rp = rp->next) - allRegions += DiffPtrs(rp->end,rp->base); - for (rp = p->stringregion->prev; rp; rp = rp->prev) - allRegions += DiffPtrs(rp->end,rp->base); - suspend C_integer allRegions; - - allRegions = 0; - for (rp = p->blockregion; rp; rp = rp->next) - allRegions += DiffPtrs(rp->end,rp->base); - for (rp = p->blockregion->prev; rp; rp = rp->prev) - allRegions += DiffPtrs(rp->end,rp->base); - return C_integer allRegions; - } - else if (strcmp(kname,"source") == 0) { - return coexpr(topact((struct b_coexpr *)BlkLoc(BlkLoc(d)->coexpr.program->K_current))); -/* - if (BlkLoc(d)->coexpr.es_actstk) - return coexpr(topact((struct b_coexpr *)BlkLoc(d))); - else return BlkLoc(d)->coexpr.program->parent->K_main; -*/ - } - else if (strcmp(kname,"storage") == 0) { - word allRegions = 0; - struct region *rp; - suspend C_integer 0; - for (rp = p->stringregion; rp; rp = rp->next) - allRegions += DiffPtrs(rp->free,rp->base); - for (rp = p->stringregion->prev; rp; rp = rp->prev) - allRegions += DiffPtrs(rp->free,rp->base); - suspend C_integer allRegions; - - allRegions = 0; - for (rp = p->blockregion; rp; rp = rp->next) - allRegions += DiffPtrs(rp->free,rp->base); - for (rp = p->blockregion->prev; rp; rp = rp->prev) - allRegions += DiffPtrs(rp->free,rp->base); - return C_integer allRegions; - } - else if (strcmp(kname,"subject") == 0) { - return kywdsubj(&(p->ksub)); - } - else if (strcmp(kname,"trace") == 0) { - return kywdint(&(p->Kywd_trc)); - } -#ifdef Graphics - else if (strcmp(kname,"window") == 0) { - return kywdwin(&(p->Kywd_xwin[XKey_Window])); - } - else if (strcmp(kname,"col") == 0) { - return kywdint(&(p->AmperCol)); - } - else if (strcmp(kname,"row") == 0) { - return kywdint(&(p->AmperRow)); - } - else if (strcmp(kname,"x") == 0) { - return kywdint(&(p->AmperX)); - } - else if (strcmp(kname,"y") == 0) { - return kywdint(&(p->AmperY)); - } - else if (strcmp(kname,"interval") == 0) { - return kywdint(&(p->AmperInterval)); - } - else if (strcmp(kname,"control") == 0) { - if (p->Xmod_Control) - return nulldesc; - else - fail; - } - else if (strcmp(kname,"shift") == 0) { - if (p->Xmod_Shift) - return nulldesc; - else - fail; - } - else if (strcmp(kname,"meta") == 0) { - if (p->Xmod_Meta) - return nulldesc; - else - fail; - } -#endif /* Graphics */ - runerr(205, keyname); - } -end -#ifdef EventMon - -"opmask(ce,cs) - get or set ce's program's opcode mask" - -function{1} opmask(ce,cs) - if !is:coexpr(ce) then runerr(118,ce) - - if is:null(cs) then { - abstract { - return cset++null - } - body { - result = BlkLoc(ce)->coexpr.program->opcodemask; - return result; - } - } - else if !cnv:cset(cs) then runerr(104,cs) - else { - abstract { - return cset - } - body { - ((struct b_coexpr *)BlkLoc(ce))->program->opcodemask = cs; - return cs; - } - } -end -#endif /* EventMon */ - - -"structure(x) -- generate all structures allocated in program x" -function {*} structure(x) - - if !is:coexpr(x) then - runerr(118, x) - - abstract { - return list ++ set ++ table ++ record - } - - body { - tended char *bp; - char *free; - tended struct descrip descr; - word type; - struct region *theregion, *rp; - -#ifdef MultiThread - theregion = ((struct b_coexpr *)BlkLoc(x))->program->blockregion; -#else - theregion = curblock; -#endif - for(rp = theregion; rp; rp = rp->next) { - bp = rp->base; - free = rp->free; - while (bp < free) { - type = BlkType(bp); - switch (type) { - case T_List: - case T_Set: - case T_Table: - case T_Record: { - BlkLoc(descr) = (union block *)bp; - descr.dword = type | F_Ptr | D_Typecode; - suspend descr; - } - } - bp += BlkSize(bp); - } - } - for(rp = theregion->prev; rp; rp = rp->prev) { - bp = rp->base; - free = rp->free; - while (bp < free) { - type = BlkType(bp); - switch (type) { - case T_List: - case T_Set: - case T_Table: - case T_Record: { - BlkLoc(descr) = (union block *)bp; - descr.dword = type | F_Ptr | D_Typecode; - suspend descr; - } - } - bp += BlkSize(bp); - } - } - fail; - } -end - - -#endif /* MultiThread */ diff --git a/src/runtime/fmonitr.r b/src/runtime/fmonitr.r deleted file mode 100644 index 8eeb95e..0000000 --- a/src/runtime/fmonitr.r +++ /dev/null @@ -1,273 +0,0 @@ -/* - * fmonitr.r -- event, EvGet - * - * This file contains event monitoring code, used only if EventMon - * (event monitoring) is defined. Event monitoring is normally is - * not enabled. - */ - -#ifdef EventMon - -/* - * Prototypes. - */ - -void mmrefresh (void); - -#define evforget() - - -char typech[MaxType+1]; /* output character for each type */ - -int noMTevents; /* don't produce events in EVAsgn */ - -#ifdef MultiThread - -static char scopechars[] = "+:^-"; - -/* - * Special event function for E_Assign; allocates out of monitor's heap. - */ -void EVAsgn(dx) -dptr dx; -{ - int i; - dptr procname; - struct progstate *parent = curpstate->parent; - struct region *rp = curpstate->stringregion; - -#if COMPILER - procname = &(PFDebug(*pfp)->proc->pname); -#else /* COMPILER */ - procname = &((&BlkLoc(*glbl_argp)->proc)->pname); -#endif /* COMPILER */ - /* - * call get_name, allocating out of the monitor if necessary. - */ - curpstate->stringregion = parent->stringregion; - parent->stringregion = rp; - noMTevents++; - i = get_name(dx,&(parent->eventval)); - - if (i == GlobalName) { - if (reserve(Strings, StrLen(parent->eventval) + 1) == NULL) - syserr("event monitoring out-of-memory error"); - StrLoc(parent->eventval) = - alcstr(StrLoc(parent->eventval), StrLen(parent->eventval)); - alcstr("+",1); - StrLen(parent->eventval)++; - } - else if (i == StaticName || i == LocalName || i == ParamName) { - if (!reserve(Strings, StrLen(parent->eventval) + StrLen(*procname) + 1)) - syserr("event monitoring out-of-memory error"); - StrLoc(parent->eventval) = - alcstr(StrLoc(parent->eventval), StrLen(parent->eventval)); - alcstr(scopechars+i,1); - alcstr(StrLoc(*procname), StrLen(*procname)); - StrLen(parent->eventval) += StrLen(*procname) + 1; - } - else if (i == Error) { - noMTevents--; - return; /* should be more violent than this */ - } - - parent->stringregion = curpstate->stringregion; - curpstate->stringregion = rp; - noMTevents--; - actparent(E_Assign); -} - - -/* - * event(x, y, C) -- generate an event at the program level. - */ - -"event(x, y, C) - create event with event code x and event value y." - -function{0,1} event(x,y,ce) - body { - struct progstate *dest; - - if (is:null(x)) { - x = curpstate->eventcode; - if (is:null(y)) y = curpstate->eventval; - } - if (is:null(ce) && is:coexpr(curpstate->parentdesc)) - ce = curpstate->parentdesc; - else if (!is:coexpr(ce)) runerr(118,ce); - dest = BlkLoc(ce)->coexpr.program; - dest->eventcode = x; - dest->eventval = y; - if (mt_activate(&(dest->eventcode),&result, - (struct b_coexpr *)BlkLoc(ce)) == A_Cofail) { - fail; - } - return result; - } -end - -/* - * EvGet(c) - user function for reading event streams. - */ - -"EvGet(c,flag) - read through the next event token having a code matched " -" by cset c." - -/* - * EvGet returns the code of the matched token. These keywords are also set: - * &eventcode token code - * &eventvalue token value - */ -function{0,1} EvGet(cs,flag) - if !def:cset(cs,fullcs) then - runerr(104,cs) - - body { - register int c; - tended struct descrip dummy; - struct progstate *p; - - /* - * Be sure an eventsource is available - */ - if (!is:coexpr(curpstate->eventsource)) - runerr(118,curpstate->eventsource); - - /* - * If our event source is a child of ours, assign its event mask. - */ - p = BlkLoc(curpstate->eventsource)->coexpr.program; - if (p->parent == curpstate) - p->eventmask = cs; - -#ifdef Graphics - if (Testb((word)E_MXevent, cs) && - is:file(kywd_xwin[XKey_Window])) { - wbp _w_ = (wbp)BlkLoc(kywd_xwin[XKey_Window])->file.fd; - pollctr = pollevent(); - if (pollctr == -1) - fatalerr(141, NULL); - if (BlkLoc(_w_->window->listp)->list.size > 0) { - c = wgetevent(_w_, &curpstate->eventval); - if (c == 0) { - StrLen(curpstate->eventcode) = 1; - StrLoc(curpstate->eventcode) = - (char *)&allchars[E_MXevent & 0xFF]; - return curpstate->eventcode; - } - else if (c == -1) - runerr(141); - else - runerr(143); - } - } -#endif /* Graphics */ - - /* - * Loop until we read an event allowed. - */ - while (1) { - /* - * Activate the event source to produce the next event. - */ - dummy = cs; - if (mt_activate(&dummy, &curpstate->eventcode, - (struct b_coexpr *)BlkLoc(curpstate->eventsource)) == - A_Cofail) fail; - deref(&curpstate->eventcode, &curpstate->eventcode); - if (!is:string(curpstate->eventcode) || - StrLen(curpstate->eventcode) != 1) { - /* - * this event is out-of-band data; return or reject it - * depending on whether flag is null. - */ - if (!is:null(flag)) - return curpstate->eventcode; - else continue; - } - - switch(*StrLoc(curpstate->eventcode)) { - case E_Cofail: case E_Coret: { - if (BlkLoc(curpstate->eventsource)->coexpr.id == 1) { - fail; - } - } - } - - return curpstate->eventcode; - } - } -end - -#endif /* MultiThread */ - -/* - * EVInit() - initialization. - */ - -void EVInit() - { - int i; - - /* - * Initialize the typech array, which is used if either file-based - * or MT-based event monitoring is enabled. - */ - - for (i = 0; i <= MaxType; i++) - typech[i] = '?'; /* initialize with error character */ - -#ifdef LargeInts - typech[T_Lrgint] = E_Lrgint; /* long integer */ -#endif /* LargeInts */ - - typech[T_Real] = E_Real; /* real number */ - typech[T_Cset] = E_Cset; /* cset */ - typech[T_File] = E_File; /* file block */ - typech[T_Record] = E_Record; /* record block */ - typech[T_Tvsubs] = E_Tvsubs; /* substring trapped variable */ - typech[T_External]= E_External; /* external block */ - typech[T_List] = E_List; /* list header block */ - typech[T_Lelem] = E_Lelem; /* list element block */ - typech[T_Table] = E_Table; /* table header block */ - typech[T_Telem] = E_Telem; /* table element block */ - typech[T_Tvtbl] = E_Tvtbl; /* table elem trapped variable*/ - typech[T_Set] = E_Set; /* set header block */ - typech[T_Selem] = E_Selem; /* set element block */ - typech[T_Slots] = E_Slots; /* set/table hash slots */ - typech[T_Coexpr] = E_Coexpr; /* co-expression block (static) */ - typech[T_Refresh] = E_Refresh; /* co-expression refresh block */ - - - /* - * codes used elsewhere but not shown here: - * in the static region: E_Alien = alien (malloc block) - * in the static region: E_Free = free - * in the string region: E_String = string - */ - } - -/* - * mmrefresh() - redraw screen, initially or after garbage collection. - */ - -void mmrefresh() - { - char *p; - word n; - - /* - * If the monitor is asking for E_EndCollect events, then it - * can handle these memory allocation "redraw" events. - */ - if (!is:null(curpstate->eventmask) && - Testb((word)E_EndCollect, curpstate->eventmask)) { - for (p = blkbase; p < blkfree; p += n) { - n = BlkSize(p); - EVVal(n, typech[(int)BlkType(p)]); /* block region */ - } - EVVal(DiffPtrs(strfree, strbase), E_String); /* string region */ - } - } - -#endif /* EventMon */ diff --git a/src/runtime/fscan.r b/src/runtime/fscan.r index 8cba731..9e974d8 100644 --- a/src/runtime/fscan.r +++ b/src/runtime/fscan.r @@ -34,7 +34,6 @@ function{0,1+} move(i) * Set new &pos. */ k_pos += i; - EVVal(k_pos, E_Spos); /* * Make sure i >= 0. @@ -56,7 +55,6 @@ function{0,1+} move(i) runerr(205, kywd_pos); else { k_pos = oldpos; - EVVal(k_pos, E_Spos); } fail; @@ -116,7 +114,6 @@ function{0,1+} tab(i) * Set new &pos. */ k_pos = i; - EVVal(k_pos, E_Spos); /* * Make i the length of the substring &subject[i:j] @@ -141,7 +138,6 @@ function{0,1+} tab(i) runerr(205, kywd_pos); else { k_pos = oldpos; - EVVal(k_pos, E_Spos); } fail; diff --git a/src/runtime/fstr.r b/src/runtime/fstr.r index 08d9f10..974aa56 100644 --- a/src/runtime/fstr.r +++ b/src/runtime/fstr.r @@ -214,10 +214,6 @@ function{1} detab(s,i[n]) return result; else { long n = DiffPtrs(StrLoc(result),strfree); /* note deallocation */ - if (n < 0) - EVVal(-n, E_StrDeAlc); - else - EVVal(n, E_String); strtotal += DiffPtrs(StrLoc(result),strfree); strfree = StrLoc(result); /* reset the free pointer */ return s; /* return original string */ @@ -337,20 +333,12 @@ function{1} entab(s,i[n]) long n; StrLen(result) = DiffPtrs(out,StrLoc(result)); n = DiffPtrs(out,strfree); /* note the deallocation */ - if (n < 0) - EVVal(-n, E_StrDeAlc); - else - EVVal(n, E_String); strtotal += DiffPtrs(out,strfree); strfree = out; /* give back unused space */ return result; /* return new string */ } else { long n = DiffPtrs(StrLoc(result),strfree); /* note the deallocation */ - if (n < 0) - EVVal(-n, E_StrDeAlc); - else - EVVal(n, E_String); strtotal += DiffPtrs(StrLoc(result),strfree); strfree = StrLoc(result); /* reset free pointer */ return s; /* return original string */ @@ -445,12 +433,6 @@ function{1} map(s1,s2,s3) */ if !cnv:string(s1) then runerr(103,s1) -#if COMPILER - if !def:string(s2, ucase) then - runerr(103,s2) - if !def:string(s3, lcase) then - runerr(103,s3) -#endif /* COMPILER */ abstract { return string @@ -461,12 +443,11 @@ function{1} map(s1,s2,s3) register char *str1, *str2, *str3; static char maptab[256]; -#if !COMPILER if (is:null(s2)) s2 = ucase; if (is:null(s3)) s3 = lcase; -#endif /* !COMPILER */ + /* * If s2 and s3 are the same as for the last call of map, * the current values in maptab can be used. Otherwise, the @@ -475,13 +456,11 @@ function{1} map(s1,s2,s3) if (!EqlDesc(maps2,s2) || !EqlDesc(maps3,s3)) { maps2 = s2; maps3 = s3; - -#if !COMPILER if (!cnv:string(s2,s2)) runerr(103,s2); if (!cnv:string(s3,s3)) runerr(103,s3); -#endif /* !COMPILER */ + /* * s2 and s3 must be of the same length */ diff --git a/src/runtime/fstruct.r b/src/runtime/fstruct.r index 469c3c5..3e5972a 100644 --- a/src/runtime/fstruct.r +++ b/src/runtime/fstruct.r @@ -34,8 +34,6 @@ function{1} delete(s,x) (BlkLoc(s)->set.size)--; } - EVValD(&s, E_Sdelete); - EVValD(&x, E_Sval); return s; } table: @@ -54,8 +52,6 @@ function{1} delete(s,x) (BlkLoc(s)->table.size)--; } - EVValD(&s, E_Tdelete); - EVValD(&x, E_Tsub); return s; } default: @@ -89,11 +85,7 @@ struct descrip *res; if (bp->nused <= 0) { bp = (struct b_lelem *) bp->listnext; hp->listhead = (union block *) bp; -#ifdef ListFix - bp->listprev = (union block *) hp; -#else /* ListFix */ bp->listprev = NULL; -#endif /* ListFix */ } /* @@ -131,7 +123,6 @@ function{0,1} get_or_pop(x) } body { - EVValD(&x, E_Lget); if (!c_get((struct b_list *)BlkLoc(x), &result)) fail; return result; } @@ -156,10 +147,8 @@ function{*} key(t) tended union block *ep; struct hgstate state; - EVValD(&t, E_Tkey); for (ep = hgfirst(BlkLoc(t), &state); ep != 0; ep = hgnext(BlkLoc(t), &state, ep)) { - EVValD(&ep->telem.tref, E_Tsub); suspend ep->telem.tref; } fail; @@ -215,8 +204,6 @@ function{1} insert(s, x, y) else deallocate((union block *)se); - EVValD(&s, E_Sinsert); - EVValD(&x, E_Sval); return s; } } @@ -264,8 +251,6 @@ function{1} insert(s, x, y) te->tval = y; } - EVValD(&s, E_Tinsert); - EVValD(&x, E_Tsub); return s; } } @@ -313,9 +298,6 @@ function{1} list(n, x) Protect(hp = alclist(size), runerr(0)); Protect(bp = alclstb(nslots, (word)0, size), runerr(0)); hp->listhead = hp->listtail = (union block *) bp; -#ifdef ListFix - bp->listprev = bp->listnext = (union block *) hp; -#endif /* ListFix */ /* * Initialize each slot. @@ -323,8 +305,6 @@ function{1} list(n, x) for (i = 0; i < size; i++) bp->lslots[i] = x; - Desc_EVValD(hp, E_Lcreate, D_List); - /* * Return the new list. */ @@ -347,9 +327,6 @@ function{0,1} member(s, x) int res; register uword hn; - EVValD(&s, E_Smember); - EVValD(&x, E_Sval); - hn = hash(&x); memb(BlkLoc(s), &x, hn, &res); if (res==1) @@ -366,9 +343,6 @@ function{0,1} member(s, x) int res; register uword hn; - EVValD(&s, E_Tmember); - EVValD(&x, E_Tsub); - hn = hash(&x); memb(BlkLoc(s), &x, hn, &res); if (res == 1) @@ -400,8 +374,6 @@ function{0,1} pull(x) register struct b_list *hp; register struct b_lelem *bp; - EVValD(&x, E_Lpull); - /* * Point at list header block and fail if the list is empty. */ @@ -417,11 +389,7 @@ function{0,1} pull(x) if (bp->nused <= 0) { bp = (struct b_lelem *) bp->listprev; hp->listtail = (union block *) bp; -#ifdef ListFix - bp->listnext = (union block *) hp; -#else /* ListFix */ bp->listnext = NULL; -#endif /* ListFix */ } /* @@ -456,10 +424,6 @@ dptr val; */ bp = (struct b_lelem *) BlkLoc(*l)->list.listhead; -#ifdef EventMon /* initialize i so it's 0 if first list-element */ - i = 0; /* block isn't full */ -#endif /* EventMon */ - /* * If the first list-element block is full, allocate a new * list-element block, make it the first list-element block, @@ -489,9 +453,6 @@ dptr val; } BlkLoc(*l)->list.listhead->lelem.listprev = (union block *) bp; -#ifdef ListFix - bp->listprev = BlkLoc(*l); -#endif /* ListFix */ bp->listnext = BlkLoc(*l)->list.listhead; BlkLoc(*l)->list.listhead = (union block *) bp; } @@ -553,10 +514,6 @@ function{1} push(x, vals[n]) hp = (struct b_list *) BlkLoc(x); bp = (struct b_lelem *) hp->listhead; -#ifdef EventMon /* initialize i so it's 0 if first list-element */ - i = 0; /* block isn't full */ -#endif /* EventMon */ - /* * If the first list-element block is full, allocate a new * list-element block, make it the first list-element block, @@ -586,9 +543,6 @@ function{1} push(x, vals[n]) } hp->listhead->lelem.listprev = (union block *) bp; -#ifdef ListFix - bp->listprev = (union block *) hp; -#endif /* ListFix */ bp->listnext = hp->listhead; hp->listhead = (union block *) bp; } @@ -610,8 +564,6 @@ function{1} push(x, vals[n]) hp->size++; } - EVValD(&x, E_Lpush); - /* * Return the list. */ @@ -637,10 +589,6 @@ struct descrip *val; */ bp = (struct b_lelem *) BlkLoc(*l)->list.listtail; -#ifdef EventMon /* initialize i so it's 0 if last list-element */ - i = 0; /* block isn't full */ -#endif /* EventMon */ - /* * If the last list-element block is full, allocate a new * list-element block, make it the last list-element block, @@ -672,9 +620,6 @@ struct descrip *val; ((struct b_list *)BlkLoc(*l))->listtail->lelem.listnext = (union block *) bp; bp->listprev = ((struct b_list *)BlkLoc(*l))->listtail; -#ifdef ListFix - bp->listnext = BlkLoc(*l); -#endif /* ListFix */ ((struct b_list *)BlkLoc(*l))->listtail = (union block *) bp; } @@ -733,10 +678,6 @@ function{1} put(x, vals[n]) hp = (struct b_list *)BlkLoc(x); bp = (struct b_lelem *) hp->listtail; -#ifdef EventMon /* initialize i so it's 0 if last list-element */ - i = 0; /* block isn't full */ -#endif /* EventMon */ - /* * If the last list-element block is full, allocate a new * list-element block, make it the last list-element block, @@ -766,9 +707,6 @@ function{1} put(x, vals[n]) hp->listtail->lelem.listnext = (union block *) bp; bp->listprev = hp->listtail; -#ifdef ListFix - bp->listnext = (union block *)hp; -#endif /* ListFix */ hp->listtail = (union block *) bp; } @@ -789,8 +727,6 @@ function{1} put(x, vals[n]) } - EVValD(&x, E_Lput); - /* * Return the list. */ @@ -815,7 +751,6 @@ function{1} set(l) ps = hmake(T_Set, (word)0, (word)0); if (ps == NULL) runerr(0); - Desc_EVValD(ps, E_Screate, D_Set); return set(ps); } } @@ -854,11 +789,7 @@ function{1} set(l) Protect(ne = alcselem(&nulldesc, (uword)0), runerr(0)); for (pb = pb->list.listhead; -#ifdef ListFix - BlkType(pb) == T_Lelem; -#else /* ListFix */ pb != NULL; -#endif /* ListFix */ pb = pb->lelem.listnext) { for (i = 0; i < pb->lelem.nused; i++) { j = pb->lelem.first + i; @@ -876,7 +807,6 @@ function{1} set(l) } } deallocate((union block *)ne); - Desc_EVValD(ps, E_Screate, D_Set); return set(ps); } } @@ -900,7 +830,6 @@ function{1} table(x) if (bp == NULL) runerr(0); bp->table.defvalue = x; - Desc_EVValD(bp, E_Tcreate, D_Table); return table(bp); } end diff --git a/src/runtime/fsys.r b/src/runtime/fsys.r index 6b70b65..6889515 100644 --- a/src/runtime/fsys.r +++ b/src/runtime/fsys.r @@ -262,9 +262,6 @@ function{0,1} open(fname, spec) Protect(hp = alclist(0), runerr(0)); Protect(bp = alclstb(MinListSlots, (word)0, 0), runerr(0)); hp->listhead = hp->listtail = (union block *) bp; -#ifdef ListFix - bp->listprev = bp->listnext = (union block *) hp; -#endif /* ListFix */ /* * loop through attributes, checking validity @@ -537,10 +534,6 @@ function{0,1} reads(f,i) * We may not have used the entire amount of storage we reserved. */ nbytes = DiffPtrs(StrLoc(s) + tally, strfree); - if (nbytes < 0) - EVVal(-nbytes, E_StrDeAlc); - else - EVVal(nbytes, E_String); strtotal += nbytes; strfree = StrLoc(s) + tally; return s; diff --git a/src/runtime/fwindow.r b/src/runtime/fwindow.r index 010286f..cc1b9c7 100644 --- a/src/runtime/fwindow.r +++ b/src/runtime/fwindow.r @@ -1624,29 +1624,18 @@ function{3} Pixel(argv[argc]) Protect((StrLoc(lastval) = alcstr(strout, slen)), runerr(0)); StrLen(lastval) = slen; } -#if COMPILER - suspend lastval; /* memory leak on vanquish */ -#else /* COMPILER */ /* * suspend, but free up imem if vanquished; RTL workaround * Needs implementing under the compiler. */ r_args[0] = lastval; -#ifdef EventMon - if ((signal = interp(G_Fsusp, r_args)) != A_Resume) { -#else /* EventMon */ if ((signal = interp(G_Csusp, r_args)) != A_Resume) { -#endif /* EventMon */ tend = r_tend.previous; getpixel_term(w, &imem); VanquishReturn(signal); } -#endif /* COMPILER */ } else { -#if COMPILER - suspend C_integer rv; /* memory leak on vanquish */ -#else /* COMPILER */ int signal; /* * suspend, but free up imem if vanquished; RTL workaround @@ -1654,16 +1643,11 @@ function{3} Pixel(argv[argc]) */ r_args[0].dword = D_Integer; r_args[0].vword.integr = rv; -#ifdef EventMon - if ((signal = interp(G_Fsusp, r_args)) != A_Resume) { -#else /* EventMon */ if ((signal = interp(G_Csusp, r_args)) != A_Resume) { -#endif /* EventMon */ tend = r_tend.previous; getpixel_term(w, &imem); VanquishReturn(signal); } -#endif /* COMPILER */ } } } diff --git a/src/runtime/imain.r b/src/runtime/imain.r index 424a4f6..7286666 100644 --- a/src/runtime/imain.r +++ b/src/runtime/imain.r @@ -1,4 +1,3 @@ -#if !COMPILER /* * File: imain.r * Interpreter main program, argument handling, and such. @@ -28,36 +27,6 @@ int iconx(int argc, char *argv[]) { static word istart[4]; static int mterm = Op_Quit; - #ifdef MultiThread - /* - * Look for MultiThread programming environment in which to execute - * this program, specified by MTENV environment variable. - */ - { - char *p; - char **new_argv; - int i, j = 1, k = 1; - if ((p = getenv("MTENV")) != NULL) { - for(i=0;p[i];i++) - if (p[i] == ' ') - j++; - new_argv = malloc((argc + j) * sizeof(char *)); - new_argv[0] = argv[0]; - for (i=0; p[i]; ) { - new_argv[k++] = p+i; - while (p[i] && (p[i] != ' ')) - i++; - if (p[i] == ' ') - p[i++] = '\0'; - } - for(i=1;i<argc;i++) - new_argv[k++] = argv[i]; - argc += j; - argv = new_argv; - } - } - #endif /* MultiThread */ - ipc.opnd = NULL; #ifdef LoadFunc @@ -69,7 +38,7 @@ int iconx(int argc, char *argv[]) { p = getenv("FPATH"); q = relfile(argv[0], "/.."); sprintf(buf, "FPATH=%s %s", (p ? p : "."), (q ? q : ".")); - putenv(buf); + putenv(salloc(buf)); } #endif /* LoadFunc */ @@ -191,54 +160,8 @@ int argc; char **argv; int *ip; { - - #ifdef TallyOpt - extern int tallyopt; - #endif /* TallyOpt */ - *ip = 0; /* number of arguments processed */ - #if MSWIN - /* - * if we didn't start with iconx.exe, backup one - * so that our icode filename is argv[1]. - */ - { - char tmp[256], *t2, *basename, *ext; - int len = 0; - strcpy(tmp, argv[0]); - for (t2 = tmp; *t2; t2++) { - switch (*t2) { - case ':': - case '/': - case '\\': - basename = t2 + 1; - ext = NULL; - break; - case '.': - ext = t2; - break; - default: - *t2 = tolower(*t2); - break; - } - } - /* If present, cut the ".exe" extension. */ - if (ext != NULL && !strcmp(ext, ".exe")) - *ext = 0; - - /* - * if argv[0] is not a reference to our interpreter, take it as the - * name of the icode file, and back up for it. - */ - if (strcmp(basename, "iconx")) { - argv--; - argc++; - (*ip)--; - } - } - #endif /* MSWIN */ - /* * Handle command line options. */ @@ -246,20 +169,12 @@ int *ip; switch ( *(argv[1]+1) ) { - #ifdef TallyOpt - /* - * Set tallying flag if -T option given - */ - case 'T': - tallyopt = 1; - break; - #endif /* TallyOpt */ - /* * Announce version on stderr if -V is given. */ case 'V': - fprintf(stderr, "%s (%s, %s)\n", Version, Config, __DATE__); + fprintf(stderr, "%s (%s %d/%d, %s)\n", + Version, Config, IntBits, WordBits, __DATE__); if (!argv[2]) exit(0); break; @@ -276,26 +191,13 @@ int *ip; * resolve - perform various fix-ups on the data read from the icode * file. */ -#ifdef MultiThread - void resolve(pstate) - struct progstate *pstate; -#else /* MultiThread */ - void resolve() -#endif /* MultiThread */ +void resolve() { register word i, j; register struct b_proc *pp; register dptr dp; extern int Omkrec(); - #ifdef MultiThread - register struct progstate *savedstate; - #endif /* MultiThread */ - - #ifdef MultiThread - savedstate = curpstate; - if (pstate) curpstate = pstate; - #endif /* MultiThread */ /* * Relocate the names of the global variables. @@ -372,13 +274,6 @@ int *ip; /* * Relocate the names of the fields. */ - for (dp = fnames; dp < efnames; dp++) StrLoc(*dp) = strcons + (uword)StrLoc(*dp); - - #ifdef MultiThread - curpstate = savedstate; - #endif /* MultiThread */ } - -#endif /* !COMPILER */ diff --git a/src/runtime/imisc.r b/src/runtime/imisc.r index cde8a90..758a0ab 100644 --- a/src/runtime/imisc.r +++ b/src/runtime/imisc.r @@ -1,4 +1,3 @@ -#if !COMPILER /* * File: imisc.r * Contents: field, mkrec, limit, llist, bscan, escan @@ -14,18 +13,8 @@ LibDcl(field,2,".") register struct b_record *rp; register dptr dp; -#ifdef MultiThread - register union block *bptr; -#else /* MultiThread */ extern int *ftabp; - #ifdef FieldTableCompression - extern int *fo; - extern unsigned char *focp; - extern short *fosp; - extern char *bm; - #endif /* FieldTableCompression */ extern word *records; -#endif /* MultiThread */ Deref(Arg1); @@ -41,74 +30,14 @@ LibDcl(field,2,".") * Map the field number into a field number for the record x. */ rp = (struct b_record *) BlkLoc(Arg1); - -#ifdef MultiThread - bptr = rp->recdesc; - if (!InRange(curpstate->Records, bptr, curpstate->Ftabp)) { - int i; - int nfields = bptr->proc.nfields; - /* - * Look up the field number by a brute force search through - * the record constructor's field names. - */ - Arg0 = fnames[IntVal(Arg2)]; - fprintf(stderr,"looking up interprogram field %.*s\n", StrLen(Arg0), - StrLoc(Arg0)); - for (i=0;i<nfields;i++){ - if ((StrLen(Arg0) == StrLen(bptr->proc.lnames[i])) && - !strncmp(StrLoc(Arg0), StrLoc(bptr->proc.lnames[i]),StrLen(Arg0))) - break; - } - if (i<nfields) fnum = i; - else fnum = -1; - } - else -#endif /* MultiThread */ - -#ifdef FieldTableCompression -#define FO(i) ((foffwidth==1)?focp[i]:((foffwidth==2)?fosp[i]:fo[i])) -#define FTAB(i) ((ftabwidth==1)?ftabcp[i]:((ftabwidth==2)?ftabsp[i]:ftabp[i])) -#else /* FieldTableCompression */ -#define FO(i) fo[i] -#define FTAB(i) ftabp[i] -#endif /* FieldTableCompression */ - -#ifdef FieldTableCompression - fnum = FTAB(FO(IntVal(Arg2)) + (rp->recdesc->proc.recnum - 1)); -#else /* FieldTableCompression */ - fnum = FTAB(IntVal(Arg2) * *records + rp->recdesc->proc.recnum - 1); -#endif /* FieldTableCompression */ + fnum = ftabp[IntVal(Arg2) * *records + rp->recdesc->proc.recnum - 1]; /* * If fnum < 0, x doesn't contain the specified field. */ - -#ifdef FieldTableCompression -{ - int bytes, index; - unsigned char this_bit = 0200; - - bytes = *records >> 3; - if ((*records & 07) != 0) - bytes++; - index = IntVal(Arg2) * bytes + (rp->recdesc->proc.recnum - 1) / 8; - this_bit = this_bit >> (rp->recdesc->proc.recnum - 1) % 8; - if ((bm[index] | this_bit) != bm[index]) - RunErr(207, &Arg1); -} - - if (ftabwidth == 1) { - if (fnum == 255) - RunErr(207, &Arg1); - } - else -#endif /* FieldTableCompression */ if (fnum < 0) RunErr(207, &Arg1); - EVValD(&Arg1, E_Rref); - EVVal(fnum + 1, E_Rsub); - /* * Return a pointer to the descriptor for the appropriate field. */ @@ -156,7 +85,6 @@ LibDcl(mkrec,-1,"mkrec") ArgType(0) = D_Record; Arg0.vword.bptr = (union block *)rp; - EVValD(&Arg0, E_Rcreate); Return; } @@ -215,8 +143,6 @@ LibDcl(bscan,2,"?") if (!cnv:string(Arg0,Arg0)) RunErr(103, &Arg0); - EVValD(&Arg0, E_Snew); - /* * Establish a new &subject value and set &pos to 1. */ @@ -238,13 +164,6 @@ LibDcl(bscan,2,"?") rc = interp(G_Csusp,cargp); -#ifdef EventMon - if (rc != A_Resume) - EVValD(&Arg1, E_Srem); - else - EVValD(&Arg1, E_Sfail); -#endif /* EventMon */ - if (pfp != cur_pfp) return rc; @@ -326,8 +245,6 @@ LibDcl(escan,1,"escan") * Suspend with the value of the scanning expression. */ - EVValD(&k_subject, E_Ssusp); - rc = interp(G_Csusp,cargp); if (pfp != cur_pfp) return rc; @@ -340,11 +257,6 @@ LibDcl(escan,1,"escan") k_subject = *VarLoc(Arg1); *VarLoc(Arg1) = tmp; -#ifdef EventMon - if (rc == A_Resume) - EVValD(&k_subject, E_Sresum); -#endif /* EventMon */ - tmp = *(VarLoc(Arg1) + 1); IntVal(*(VarLoc(Arg1) + 1)) = k_pos; k_pos = IntVal(tmp); @@ -354,4 +266,3 @@ LibDcl(escan,1,"escan") return rc; } -#endif /* !COMPILER */ diff --git a/src/runtime/init.r b/src/runtime/init.r index 248bda8..d0bc00b 100644 --- a/src/runtime/init.r +++ b/src/runtime/init.r @@ -9,19 +9,18 @@ static void env_err (char *msg, char *name, char *val); FILE *pathOpen (char *fname, char *mode); -#if !COMPILER - #include "../h/header.h" - static FILE *readhdr(char *name, struct header *hdr); +#include "../h/header.h" +static FILE *readhdr(char *name, struct header *hdr); - #passthru #define OpDef(p,n,s,u) int Cat(O,p) (dptr cargp); - #passthru #include "../h/odefs.h" - #passthru #undef OpDef +#passthru #define OpDef(p,n,s,u) int Cat(O,p) (dptr cargp); +#passthru #include "../h/odefs.h" +#passthru #undef OpDef - /* - * External declarations for operator blocks. - */ +/* + * External declarations for operator blocks. + */ - #passthru #define OpDef(f,nargs,sname,underef)\ +#passthru #define OpDef(f,nargs,sname,underef)\ {\ T_Proc,\ Vsizeof(struct b_proc),\ @@ -31,11 +30,10 @@ FILE *pathOpen (char *fname, char *mode); underef,\ 0,\ {{sizeof(sname)-1,sname}}}, - #passthru static B_IProc(2) init_op_tbl[] = { - #passthru #include "../h/odefs.h" - #passthru }; - #undef OpDef -#endif /* !COMPILER */ +#passthru static B_IProc(2) init_op_tbl[] = { +#passthru #include "../h/odefs.h" +#passthru }; +#undef OpDef #ifdef WinGraphics static void MSStartup(HINSTANCE hInstance, HINSTANCE hPrevInstance); @@ -58,10 +56,7 @@ word mstksize = MStackSize; /* initial size of main stack */ word stksize = StackSize; /* co-expression stack size */ int k_level = 0; /* &level */ - -#ifndef MultiThread - struct descrip k_main; /* &main */ -#endif /* MultiThread */ +struct descrip k_main; /* &main */ int ixinited = 0; /* set-up switch */ @@ -74,10 +69,8 @@ word memcushion = RegionCushion; /* memory region cushion factor */ word memgrowth = RegionGrowth; /* memory region growth factor */ uword stattotal = 0; /* cumulative total static allocation */ -#ifndef MultiThread - uword strtotal = 0; /* cumulative total string allocation */ - uword blktotal = 0; /* cumulative total block allocation */ -#endif /* MultiThread */ +uword strtotal = 0; /* cumulative total string allocation */ +uword blktotal = 0; /* cumulative total block allocation */ int dodump; /* if nonzero, core dump on error */ int noerrbuf; /* if nonzero, do not buffer stderr */ @@ -85,16 +78,14 @@ int noerrbuf; /* if nonzero, do not buffer stderr */ struct descrip maps2; /* second cached argument of map */ struct descrip maps3; /* third cached argument of map */ -#ifndef MultiThread - struct descrip k_current; /* current expression stack pointer */ - int k_errornumber = 0; /* &errornumber */ - char *k_errortext = ""; /* &errortext */ - struct descrip k_errorvalue; /* &errorvalue */ - int have_errval = 0; /* &errorvalue has legal value */ - int t_errornumber = 0; /* tentative k_errornumber value */ - int t_have_val = 0; /* tentative have_errval flag */ - struct descrip t_errorvalue; /* tentative k_errorvalue value */ -#endif /* MultiThread */ +struct descrip k_current; /* current expression stack pointer */ +int k_errornumber = 0; /* &errornumber */ +char *k_errortext = ""; /* &errortext */ +struct descrip k_errorvalue; /* &errorvalue */ +int have_errval = 0; /* &errorvalue has legal value */ +int t_errornumber = 0; /* tentative k_errornumber value */ +int t_have_val = 0; /* tentative have_errval flag */ +struct descrip t_errorvalue; /* tentative k_errorvalue value */ struct b_coexpr *stklist; /* base of co-expression block list */ @@ -102,80 +93,38 @@ struct tend_desc *tend = NULL; /* chain of tended descriptors */ struct region rootstring, rootblock; -#ifndef MultiThread - dptr glbl_argp = NULL; /* argument pointer */ - dptr globals, eglobals; /* pointer to global variables */ - dptr gnames, egnames; /* pointer to global variable names */ - dptr estatics; /* pointer to end of static variables */ - struct region *curstring, *curblock; - #if !COMPILER - int n_globals = 0; /* number of globals */ - int n_statics = 0; /* number of statics */ - #endif /* !COMPILER */ -#endif /* MultiThread */ - -#if COMPILER - struct p_frame *pfp = NULL; /* procedure frame pointer */ - - int debug_info; /* flag: is debugging information available */ - int err_conv; /* flag: is error conversion supported */ - int largeints; /* flag: large integers are supported */ - - struct b_coexpr *mainhead; /* &main */ - -#else /* COMPILER */ - - int debug_info=1; /* flag: debugging information IS available */ - int err_conv=1; /* flag: error conversion IS supported */ - - int op_tbl_sz = (sizeof(init_op_tbl) / sizeof(struct b_proc)); - struct pf_marker *pfp = NULL; /* Procedure frame pointer */ - - #ifdef MultiThread - struct progstate *curpstate; /* lastop accessed in program state */ - struct progstate rootpstate; - #else /* MultiThread */ - - struct b_coexpr *mainhead; /* &main */ - - char *code; /* interpreter code buffer */ - char *ecode; /* end of interpreter code buffer */ - word *records; /* pointer to record procedure blocks */ - - int *ftabp; /* pointer to record/field table */ - - #ifdef FieldTableCompression - word ftabwidth; /* field table entry width */ - word foffwidth; /* field offset entry width */ - unsigned char *ftabcp, *focp; /* pointers to record/field table */ - short *ftabsp, *fosp; /* pointers to record/field table */ - - int *fo; /* field offset (row in field table) */ - char *bm; /* bitmap array of valid field bits */ - #endif /* FieldTableCompression */ - - dptr fnames, efnames; /* pointer to field names */ - dptr statics; /* pointer to static variables */ - char *strcons; /* pointer to string constant table */ - struct ipc_fname *filenms, *efilenms; /* pointer to ipc/file name table */ - struct ipc_line *ilines, *elines; /* pointer to ipc/line number table */ - #endif /* MultiThread */ - - #ifdef TallyOpt - word tallybin[16]; /* counters for tallying */ - int tallyopt = 0; /* want tally results output? */ - #endif /* TallyOpt */ - - word *stack; /* Interpreter stack */ - word *stackend; /* End of interpreter stack */ - -#endif /* COMPILER */ +dptr glbl_argp = NULL; /* argument pointer */ +dptr globals, eglobals; /* pointer to global variables */ +dptr gnames, egnames; /* pointer to global variable names */ +dptr estatics; /* pointer to end of static variables */ +struct region *curstring, *curblock; +int n_globals = 0; /* number of globals */ +int n_statics = 0; /* number of statics */ + +int debug_info=1; /* flag: debugging information IS available */ +int err_conv=1; /* flag: error conversion IS supported */ + +int op_tbl_sz = (sizeof(init_op_tbl) / sizeof(struct b_proc)); +struct pf_marker *pfp = NULL; /* Procedure frame pointer */ + + struct b_coexpr *mainhead; /* &main */ + + char *code; /* interpreter code buffer */ + char *ecode; /* end of interpreter code buffer */ + word *records; /* pointer to record procedure blocks */ + int *ftabp; /* pointer to record/field table */ + dptr fnames, efnames; /* pointer to field names */ + dptr statics; /* pointer to static variables */ + char *strcons; /* pointer to string constant table */ + struct ipc_fname *filenms, *efilenms; /* pointer to ipc/file name table */ + struct ipc_line *ilines, *elines; /* pointer to ipc/line number table */ + +word *stack; /* Interpreter stack */ +word *stackend; /* End of interpreter stack */ -#if !COMPILER - /* * Open the icode file and read the header. - * Used by icon_init() as well as MultiThread's loadicode() + * Used by icon_init(). */ static FILE *readhdr(name,hdr) char *name; @@ -249,35 +198,21 @@ struct header *hdr; return fname; } - -#endif /* !COMPILER */ /* * init/icon_init - initialize memory and prepare for Icon execution. */ -#if !COMPILER - struct header hdr; -#endif /* !COMPILER */ - -#if COMPILER - void init(name, argcp, argv, trc_init) - char *name; - int *argcp; - char *argv[]; - int trc_init; -#else /* COMPILER */ - void icon_init(name, argcp, argv) - char *name; - int *argcp; - char *argv[]; -#endif /* COMPILER */ +struct header hdr; +void icon_init(name, argcp, argv) +char *name; +int *argcp; +char *argv[]; { + char *itval; int delete_icode = 0; -#if !COMPILER FILE *fname = NULL; word cbread, longread(); -#endif /* COMPILER */ prog_name = name; /* Set icode file name */ @@ -303,80 +238,18 @@ struct header *hdr; * from icont to delete icode file xxxxx and to use yyyyy for &progname. * (This is used with Unix "#!" script files written in Icon.) */ - { - char *itval = getenv("ICODE_TEMP"); - int nlen = strlen(name); - if (itval != NULL && itval[nlen] == ':' && strncmp(name,itval,nlen)==0) { - delete_icode = 1; - prog_name = itval + nlen + 1; - } + itval = getenv("ICODE_TEMP"); + if (itval != NULL && strncmp(name, itval, strlen(name)) == 0) { + delete_icode = 1; + prog_name = strchr(itval, ':') + 1; + prog_name[-1] = '\0'; } -#if COMPILER curstring = &rootstring; curblock = &rootblock; rootstring.size = MaxStrSpace; rootblock.size = MaxAbrSize; -#else /* COMPILER */ - -#ifdef MultiThread - /* - * initialize root pstate - */ - curpstate = &rootpstate; - rootpstate.parentdesc = nulldesc; - rootpstate.eventmask= nulldesc; - rootpstate.opcodemask = nulldesc; - rootpstate.eventcode= nulldesc; - rootpstate.eventval = nulldesc; - rootpstate.eventsource = nulldesc; - rootpstate.Glbl_argp = NULL; - MakeInt(0, &(rootpstate.Kywd_err)); - MakeInt(1, &(rootpstate.Kywd_pos)); - StrLen(rootpstate.ksub) = 0; - StrLoc(rootpstate.ksub) = ""; - MakeInt(hdr.trace, &(rootpstate.Kywd_trc)); - StrLen(rootpstate.Kywd_prog) = strlen(prog_name); - StrLoc(rootpstate.Kywd_prog) = prog_name; - MakeInt(0, &(rootpstate.Kywd_ran)); - rootpstate.K_errornumber = 0; - rootpstate.T_errornumber = 0; - rootpstate.Have_errval = 0; - rootpstate.T_have_val = 0; - rootpstate.K_errortext = ""; - rootpstate.K_errorvalue = nulldesc; - rootpstate.T_errorvalue = nulldesc; - -#ifdef Graphics - MakeInt(0,&(rootpstate.AmperX)); - MakeInt(0,&(rootpstate.AmperY)); - MakeInt(0,&(rootpstate.AmperRow)); - MakeInt(0,&(rootpstate.AmperCol)); - MakeInt(0,&(rootpstate.AmperInterval)); - rootpstate.LastEventWin = nulldesc; - rootpstate.Kywd_xwin[XKey_Window] = nulldesc; -#endif /* Graphics */ - - rootpstate.Coexp_ser = 2; - rootpstate.List_ser = 1; - rootpstate.Set_ser = 1; - rootpstate.Table_ser = 1; - rootpstate.stringregion = &rootstring; - rootpstate.blockregion = &rootblock; - -#else /* MultiThread */ - - curstring = &rootstring; - curblock = &rootblock; -#endif /* MultiThread */ - - rootstring.size = MaxStrSpace; - rootblock.size = MaxAbrSize; -#endif /* COMPILER */ - -#if !COMPILER op_tbl = (struct b_proc*)init_op_tbl; -#endif /* !COMPILER */ #ifdef Double if (sizeof(struct size_dbl) != sizeof(double)) @@ -395,14 +268,10 @@ struct header *hdr; datainit(); - #if COMPILER - IntVal(kywd_trc) = trc_init; - #else /* COMPILER */ - fname = readhdr(name,&hdr); - if (fname == NULL) - error(name, "cannot open interpreter file"); - k_trace = hdr.trace; - #endif /* COMPILER */ + fname = readhdr(name,&hdr); + if (fname == NULL) + error(name, "cannot open interpreter file"); + k_trace = hdr.trace; /* * Examine the environment and make appropriate settings. [[I?]] @@ -418,41 +287,14 @@ struct header *hdr; /* * Allocate memory for various regions. */ -#if COMPILER - initalloc(); -#else /* COMPILER */ -#ifdef MultiThread - initalloc(hdr.hsize,&rootpstate); -#else /* MultiThread */ initalloc(hdr.hsize); -#endif /* MultiThread */ -#endif /* COMPILER */ -#if !COMPILER /* * Establish pointers to icode data regions. [[I?]] */ ecode = code + hdr.Records; records = (word *)ecode; ftabp = (int *)(code + hdr.Ftab); -#ifdef FieldTableCompression - fo = (int *)(code + hdr.Fo); - focp = (unsigned char *)(fo); - fosp = (short *)(fo); - if (hdr.FoffWidth == 1) { - bm = (char *)(focp + hdr.Nfields); - } - else if (hdr.FoffWidth == 2) { - bm = (char *)(fosp + hdr.Nfields); - } - else - bm = (char *)(fo + hdr.Nfields); - - ftabwidth = hdr.FtabWidth; - foffwidth = hdr.FoffWidth; - ftabcp = (unsigned char *)(code + hdr.Ftab); - ftabsp = (short *)(code + hdr.Ftab); -#endif /* FieldTableCompression */ fnames = (dptr)(code + hdr.Fnames); globals = efnames = (dptr)(code + hdr.Globals); gnames = eglobals = (dptr)(code + hdr.Gnames); @@ -465,26 +307,14 @@ struct header *hdr; strcons = (char *)elines; n_globals = eglobals - globals; n_statics = estatics - statics; -#endif /* COMPILER */ /* * Allocate stack and initialize &main. */ - -#if COMPILER - mainhead = (struct b_coexpr *)malloc(sizeof(struct b_coexpr)); -#else /* COMPILER */ stack = (word *)malloc(mstksize); mainhead = (struct b_coexpr *)stack; - -#endif /* COMPILER */ - if (mainhead == NULL) -#if COMPILER - err_msg(305, NULL); -#else /* COMPILER */ fatalerr(303, NULL); -#endif /* COMPILER */ mainhead->title = T_Coexpr; mainhead->id = 1; @@ -493,18 +323,8 @@ struct header *hdr; mainhead->es_tend = NULL; mainhead->freshblk = nulldesc; /* &main has no refresh block. */ /* This really is a bug. */ -#ifdef MultiThread - mainhead->program = &rootpstate; -#endif /* MultiThread */ -#if COMPILER - mainhead->file_name = ""; - mainhead->line_num = 0; -#endif /* COMPILER */ - -#ifdef Coexpr Protect(mainhead->es_actstk = alcactiv(), fatalerr(0,NULL)); pushact(mainhead, mainhead); -#endif /* Coexpr */ /* * Point &main at the co-expression block for the main procedure and set @@ -514,7 +334,6 @@ struct header *hdr; BlkLoc(k_main) = (union block *) mainhead; k_current = k_main; -#if !COMPILER /* * Read the interpretable code and data into memory. */ @@ -526,37 +345,26 @@ struct header *hdr; } fclose(fname); if (delete_icode) /* delete icode file if flag set earlier */ - remove(name); + remove(itval); -/* - * Make sure the version number of the icode matches the interpreter version. - */ + /* + * Make sure the version number of the icode matches the interpreter version. + */ if (strcmp((char *)hdr.config,IVersion)) { fprintf(stderr,"icode version mismatch in %s\n", name); fprintf(stderr,"\ticode version: %s\n",(char *)hdr.config); fprintf(stderr,"\texpected version: %s\n",IVersion); error(name, "cannot run"); } -#endif /* !COMPILER */ /* * Initialize the event monitoring system, if configured. */ -#ifdef EventMon - EVInit(); -#endif /* EventMon */ - -#if !COMPILER /* * Resolve references from icode to run-time system. */ -#ifdef MultiThread - resolve(NULL); -#else /* MultiThread */ resolve(); -#endif /* MultiThread */ -#endif /* COMPILER */ /* * Allocate and assign a buffer to stderr if possible. @@ -723,17 +531,13 @@ char *s; { fprintf(stderr, "System error"); if (pfp == NULL) - fprintf(stderr, " in startup code"); + fprintf(stderr, " in startup code\n"); else { -#if COMPILER - if (line_info) - fprintf(stderr, " at line %d in %s", line_num, file_name); -#else /* COMPILER */ - fprintf(stderr, " at line %ld in %s", (long)findline(ipc.opnd), + fprintf(stderr, " at line %ld in %s\n", (long)findline(ipc.opnd), findfile(ipc.opnd)); -#endif /* COMPILER */ } - fprintf(stderr, "\n%s\n", s); + if (s != NULL) + fprintf(stderr, "%s\n", s); fflush(stderr); if (dodump) abort(); @@ -747,35 +551,6 @@ void c_exit(i) int i; { -#ifdef EventMon - if (curpstate != NULL) { - EVVal((word)i, E_Exit); - } -#endif /* EventMon */ - -#ifdef MultiThread - if (curpstate != NULL && curpstate->parent != NULL) { - /* might want to get to the lterm somehow, instead */ - while (1) { - struct descrip dummy; - co_chng(curpstate->parent->Mainhead, NULL, &dummy, A_Cofail, 1); - } - } -#endif /* MultiThread */ - -#ifdef TallyOpt - { - int j; - - if (tallyopt) { - fprintf(stderr,"tallies: "); - for (j=0; j<16; j++) - fprintf(stderr," %ld", (long)tallybin[j]); - fprintf(stderr,"\n"); - } - } -#endif /* TallyOpt */ - if (k_dump && ixinited) { fprintf(stderr,"\nTermination dump:\n\n"); fflush(stderr); @@ -832,12 +607,6 @@ void datainit() * some compilers). [[I?]] */ -#ifdef MultiThread - k_errout.title = T_File; - k_input.title = T_File; - k_output.title = T_File; -#endif /* MultiThread */ - k_errout.fd = stderr; StrLen(k_errout.fname) = 7; StrLoc(k_errout.fname) = "&errout"; @@ -888,214 +657,11 @@ void datainit() StrLoc(ucase) = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; IntVal(zerodesc) = 0; -#ifdef EventMon -/* - * Initialization needed for event monitoring - */ - - BlkLoc(csetdesc) = (union block *)&fullcs; - BlkLoc(rzerodesc) = (union block *)&realzero; - -#endif /* EventMon */ - maps2 = nulldesc; maps3 = nulldesc; - #if !COMPILER - qsort((char *)pntab,pnsize,sizeof(struct pstrnm), (int(*)())pstrnmcmp); - #endif /* COMPILER */ - - } - -#ifdef MultiThread -/* - * loadicode - initialize memory particular to a given icode file - */ -struct b_coexpr * loadicode(name, theInput, theOutput, theError, bs, ss, stk) -char *name; -struct b_file *theInput, *theOutput, *theError; -C_integer bs, ss, stk; - { - struct b_coexpr *coexp; - struct progstate *pstate; - struct header hdr; - FILE *fname = NULL; - word cbread, longread(); - - /* - * open the icode file and read the header - */ - fname = readhdr(name,&hdr); - if (fname == NULL) - return NULL; - - /* - * Allocate memory for icode and the struct that describes it - */ - Protect(coexp = alccoexp(hdr.hsize, stk), - { fprintf(stderr,"can't malloc new icode region\n");c_exit(EXIT_FAILURE);}); - - pstate = coexp->program; - /* - * Initialize values. - */ - pstate->hsize = hdr.hsize; - pstate->parent= NULL; - pstate->parentdesc= nulldesc; - pstate->opcodemask= nulldesc; - pstate->eventmask= nulldesc; - pstate->eventcode= nulldesc; - pstate->eventval = nulldesc; - pstate->eventsource = nulldesc; - pstate->K_current.dword = D_Coexpr; - - MakeInt(0, &(pstate->Kywd_err)); - MakeInt(1, &(pstate->Kywd_pos)); - MakeInt(0, &(pstate->Kywd_ran)); - - StrLen(pstate->Kywd_prog) = strlen(prog_name); - StrLoc(pstate->Kywd_prog) = prog_name; - StrLen(pstate->ksub) = 0; - StrLoc(pstate->ksub) = ""; - MakeInt(hdr.trace, &(pstate->Kywd_trc)); - -#ifdef EventMon - pstate->Linenum = pstate->Column = pstate->Lastline = pstate->Lastcol = 0; -#endif /* EventMon */ - pstate->Lastop = 0; - /* - * might want to override from TRACE environment variable here. - */ - - /* - * Establish pointers to icode data regions. [[I?]] - */ - pstate->Mainhead= ((struct b_coexpr *)pstate)-1; - pstate->K_main.dword = D_Coexpr; - BlkLoc(pstate->K_main) = (union block *) pstate->Mainhead; - pstate->Code = (char *)(pstate + 1); - pstate->Ecode = (char *)(pstate->Code + hdr.Records); - pstate->Records = (word *)(pstate->Code + hdr.Records); - pstate->Ftabp = (int *)(pstate->Code + hdr.Ftab); -#ifdef FieldTableCompression - pstate->Fo = (int *)(pstate->Code + hdr.Fo); - pstate->Focp = (unsigned char *)(pstate->Fo); - pstate->Fosp = (short *)(pstate->Fo); - pstate->Foffwidth = hdr.FoffWidth; - if (hdr.FoffWidth == 1) { - pstate->Bm = (char *)(pstate->Focp + hdr.Nfields); - } - else if (hdr.FoffWidth == 2) { - pstate->Bm = (char *)(pstate->Fosp + hdr.Nfields); - } - else - pstate->Bm = (char *)(pstate->Fo + hdr.Nfields); - pstate->Ftabwidth= hdr.FtabWidth; - pstate->Foffwidth = hdr.FoffWidth; - pstate->Ftabcp = (unsigned char *)(pstate->Code + hdr.Ftab); - pstate->Ftabsp = (short *)(pstate->Code + hdr.Ftab); -#endif /* FieldTableCompression */ - pstate->Fnames = (dptr)(pstate->Code + hdr.Fnames); - pstate->Globals = pstate->Efnames = (dptr)(pstate->Code + hdr.Globals); - pstate->Gnames = pstate->Eglobals = (dptr)(pstate->Code + hdr.Gnames); - pstate->NGlobals = pstate->Eglobals - pstate->Globals; - pstate->Statics = pstate->Egnames = (dptr)(pstate->Code + hdr.Statics); - pstate->Estatics = (dptr)(pstate->Code + hdr.Filenms); - pstate->NStatics = pstate->Estatics - pstate->Statics; - pstate->Filenms = (struct ipc_fname *)(pstate->Estatics); - pstate->Efilenms = (struct ipc_fname *)(pstate->Code + hdr.linenums); - pstate->Ilines = (struct ipc_line *)(pstate->Efilenms); - pstate->Elines = (struct ipc_line *)(pstate->Code + hdr.Strcons); - pstate->Strcons = (char *)(pstate->Elines); - pstate->K_errornumber = 0; - pstate->T_errornumber = 0; - pstate->Have_errval = 0; - pstate->T_have_val = 0; - pstate->K_errortext = ""; - pstate->K_errorvalue = nulldesc; - pstate->T_errorvalue = nulldesc; - -#ifdef Graphics - MakeInt(0, &(pstate->AmperX)); - MakeInt(0, &(pstate->AmperY)); - MakeInt(0, &(pstate->AmperRow)); - MakeInt(0, &(pstate->AmperCol)); - MakeInt(0, &(pstate->AmperInterval)); - pstate->LastEventWin = nulldesc; - pstate->Kywd_xwin[XKey_Window] = nulldesc; -#endif /* Graphics */ - - pstate->Coexp_ser = 2; - pstate->List_ser = 1; - pstate->Set_ser = 1; - pstate->Table_ser = 1; - - pstate->stringtotal = pstate->blocktotal = - pstate->colltot = pstate->collstat = - pstate->collstr = pstate->collblk = 0; - - pstate->stringregion = (struct region *)malloc(sizeof(struct region)); - pstate->blockregion = (struct region *)malloc(sizeof(struct region)); - pstate->stringregion->size = ss; - pstate->blockregion->size = bs; - - /* - * the local program region list starts out with this region only - */ - pstate->stringregion->prev = NULL; - pstate->blockregion->prev = NULL; - pstate->stringregion->next = NULL; - pstate->blockregion->next = NULL; - /* - * the global region list links this region with curpstate's - */ - pstate->stringregion->Gprev = curpstate->stringregion; - pstate->blockregion->Gprev = curpstate->blockregion; - pstate->stringregion->Gnext = curpstate->stringregion->Gnext; - pstate->blockregion->Gnext = curpstate->blockregion->Gnext; - if (curpstate->stringregion->Gnext) - curpstate->stringregion->Gnext->Gprev = pstate->stringregion; - curpstate->stringregion->Gnext = pstate->stringregion; - if (curpstate->blockregion->Gnext) - curpstate->blockregion->Gnext->Gprev = pstate->blockregion; - curpstate->blockregion->Gnext = pstate->blockregion; - initalloc(0, pstate); - - pstate->K_errout = *theError; - pstate->K_input = *theInput; - pstate->K_output = *theOutput; - - /* - * Read the interpretable code and data into memory. - */ - if ((cbread = longread(pstate->Code, sizeof(char), (long)hdr.hsize, fname)) - != hdr.hsize) { - fprintf(stderr,"Tried to read %ld bytes of code, got %ld\n", - (long)hdr.hsize,(long)cbread); - error(name, "can't read interpreter code"); - } - fclose(fname); - - /* - * Make sure the version number of the icode matches the interpreter version - */ - if (strcmp((char *)hdr.config,IVersion)) { - fprintf(stderr,"icode version mismatch in %s\n", name); - fprintf(stderr,"\ticode version: %s\n",(char *)hdr.config); - fprintf(stderr,"\texpected version: %s\n",IVersion); - error(name, "cannot run"); - } - - /* - * Resolve references from icode to run-time system. - * The first program has this done in icon_init after - * initializing the event monitoring system. - */ - resolve(pstate); - - return coexp; + qsort((char *)pntab,pnsize,sizeof(struct pstrnm), (int(*)())pstrnmcmp); } -#endif /* MultiThread */ #ifdef WinGraphics static void MSStartup(HINSTANCE hInstance, HINSTANCE hPrevInstance) diff --git a/src/runtime/interp.r b/src/runtime/interp.r index c5fd713..6955b8f 100644 --- a/src/runtime/interp.r +++ b/src/runtime/interp.r @@ -1,4 +1,3 @@ -#if !COMPILER /* * File: interp.r * The interpreter proper. @@ -8,20 +7,7 @@ extern fptr fncentry[]; - -/* - * Prototypes for static functions. - */ -#ifdef EventMon -static struct ef_marker *vanq_bound (struct ef_marker *efp_v, - struct gf_marker *gfp_v); -static void vanq_proc (struct ef_marker *efp_v, - struct gf_marker *gfp_v); -#endif /* EventMon */ - -#ifndef MultiThread word lastop; /* Last operator evaluated */ -#endif /* MultiThread */ /* * Istate variables. @@ -37,32 +23,17 @@ struct descrip eret_tmp; /* eret value during unwinding */ int coexp_act; /* last co-expression action */ -#ifndef MultiThread dptr xargp; word xnargs; -#endif /* MultiThread */ /* * Macros for use inside the main loop of the interpreter. */ -#ifdef EventMon -#define E_Misc -1 -#define E_Operator 0 -#define E_Function 1 -#endif /* EventMon */ - /* * Setup_Op sets things up for a call to the C function for an operator. - * InterpEVValD expands to nothing if EventMon is not defined. */ #begdef Setup_Op(nargs) -#ifdef EventMon - lastev = E_Operator; - value_tmp.dword = D_Proc; - value_tmp.vword.bptr = (union block *)&op_tbl[lastop - 1]; - InterpEVValD(&value_tmp, E_Ocall); -#endif /* EventMon */ rargp = (dptr)(rsp - 1) - nargs; xargp = rargp; ExInterp; @@ -74,9 +45,6 @@ word xnargs; * operators. */ #begdef Setup_Arg(nargs) -#ifdef EventMon - lastev = E_Misc; -#endif /* EventMon */ rargp = (dptr)(rsp - 1) - nargs; xargp = rargp; ExInterp; @@ -84,17 +52,10 @@ word xnargs; #begdef Call_Cond if ((*(optab[lastop]))(rargp) == A_Resume) { -#ifdef EventMon - InterpEVVal((word)-1, E_Ofail); -#endif /* EventMon */ goto efail_noev; } rsp = (word *) rargp + 1; -#ifdef EventMon - goto return_term; -#else /* EventMon */ break; -#endif /* EventMon */ #enddef /* Call_Cond */ /* @@ -169,20 +130,7 @@ dptr cargp; extern int (*optab[])(); extern int (*keytab[])(); struct b_proc *bproc; -#ifdef EventMon - int lastev = E_Misc; -#endif /* EventMon */ - -#ifdef TallyOpt - extern word tallybin[]; -#endif /* TallyOpt */ - -#ifdef EventMon - EVVal(fsig, E_Intcall); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ -#ifndef MultiThread /* * Make a stab at catching interpreter stack overflow. This does * nothing for invocation in a co-expression other than &main. @@ -190,7 +138,6 @@ dptr cargp; if (BlkLoc(k_current) == BlkLoc(k_main) && ((char *)sp + PerilDelta) > (char *)stackend) fatalerr(301, NULL); -#endif /* MultiThread */ #ifdef Polling if (!pollctr--) { @@ -203,18 +150,7 @@ dptr cargp; EntInterp; -#ifdef EventMon - switch (fsig) { - case G_Csusp: - case G_Fsusp: - case G_Osusp: - value_tmp = *(dptr)(rsp - 1); /* argument */ - Deref(value_tmp); - InterpEVValD(&value_tmp, - (fsig == G_Fsusp)?E_Fsusp:(fsig == G_Osusp?E_Osusp:E_Bsusp)); -#else /* EventMon */ if (fsig == G_Csusp) { -#endif /* EventMon */ oldsp = rsp; @@ -256,96 +192,7 @@ dptr cargp; */ for (;;) { - -#ifdef EventMon - - /* - * Location change events are generated by checking to see if the opcode - * has changed indices in the "line number" (now line + column) table; - * "straight line" forward code does not require a binary search to find - * the new location; instead, a pointer is simply incremented. - * Further optimization here is planned. - */ - if (!is:null(curpstate->eventmask) && ( - Testb((word)E_Loc, curpstate->eventmask) || - Testb((word)E_Line, curpstate->eventmask) - )) { - - if (InRange(code, ipc.opnd, ecode)) { - uword ipc_offset = DiffPtrs((char *)ipc.opnd, (char *)code); - uword size; - word temp_no; - if (!current_line_ptr || - current_line_ptr->ipc > ipc_offset || - current_line_ptr[1].ipc <= ipc_offset) { -#ifdef LineCodes -#ifdef Polling - if (!pollctr--) { - ExInterp; - pollctr = pollevent(); - EntInterp; - if (pollctr == -1) fatalerr(141, NULL); - } -#endif /* Polling */ -#endif /* LineCodes */ - - - if(current_line_ptr && - current_line_ptr + 2 < elines && - current_line_ptr[1].ipc < ipc_offset && - ipc_offset < current_line_ptr[2].ipc) { - current_line_ptr ++; - } - else { - current_line_ptr = ilines; - size = DiffPtrs((char *)elines, (char *)ilines) / - sizeof(struct ipc_line *); - while (size > 1) { - if (ipc_offset >= current_line_ptr[size>>1].ipc) { - current_line_ptr = ¤t_line_ptr[size>>1]; - size -= (size >> 1); - } - else { - size >>= 1; - } - } - } - linenum = current_line_ptr->line; - temp_no = linenum & 65535; - if ((lastline & 65535) != temp_no) { - if (Testb((word)E_Line, curpstate->eventmask)) - if (temp_no) - InterpEVVal(temp_no, E_Line); - } - if (lastline != linenum) { - lastline = linenum; - if (Testb((word)E_Loc, curpstate->eventmask) && - current_line_ptr->line >> 16) - InterpEVVal(current_line_ptr->line, E_Loc); - } - } - } - } -#endif /* EventMon */ - lastop = GetOp; /* Instruction fetch */ - -#ifdef EventMon - /* - * If we've asked for ALL opcode events, or specifically for this one - * generate an MT-style event. - */ - if ((!is:null(curpstate->eventmask) && - Testb((word)E_Opcode, curpstate->eventmask)) && - (is:null(curpstate->opcodemask) || - Testb((word)lastop, curpstate->opcodemask))) { - ExInterp; - MakeInt(lastop, &(curpstate->parent->eventval)); - actparent(E_Opcode); - EntInterp - } -#endif /* EventMon */ - switch ((int)lastop) { /* * Switch on opcode. The cases are * organized roughly by functionality @@ -564,23 +411,12 @@ dptr cargp; if (pollctr == -1) fatalerr(141, NULL); } #endif /* Polling */ - - #endif /* LineCodes */ break; - case Op_Colm: /* source column number */ { -#ifdef EventMon - word loc; - column = GetWord; - loc = column; - loc <<= (WordBits >> 1); /* column in high-order part */ - loc += linenum; - InterpEVVal(loc, E_Loc); -#endif /* EventMon */ break; } @@ -595,15 +431,7 @@ dptr cargp; if (pollctr == -1) fatalerr(141, NULL); } #endif /* Polling */ - - #endif /* LineCodes */ - -#ifdef EventMon - linenum = GetWord; - lastline = linenum; -#endif /* EventMon */ - break; /* ---String Scanning--- */ @@ -639,7 +467,6 @@ dptr cargp; bp = BlkLoc(value_tmp); args = (int)bp->list.size; -#ifndef MultiThread /* * Make a stab at catching interpreter stack overflow. * This does nothing for invocation in a co-expression other @@ -649,14 +476,9 @@ dptr cargp; ((char *)sp + args * sizeof(struct descrip) > (char *)stackend)) fatalerr(301, NULL); -#endif /* MultiThread */ for (bp = bp->list.listhead; -#ifdef ListFix - BlkType(bp) == T_Lelem; -#else /* ListFix */ - bp != NULL; -#endif /* ListFix */ + bp != NULL; bp = bp->lelem.listnext) { for (i = 0; i < bp->lelem.nused; i++) { j = bp->lelem.first + i; @@ -719,52 +541,20 @@ invokej: } #endif /* Polling */ -#ifdef EventMon - lastev = E_Function; - InterpEVValD(rargp, E_Fcall); -#endif /* EventMon */ - bproc = (struct b_proc *)BlkLoc(*rargp); -#ifdef FncTrace - typedef int (*bfunc2)(dptr, struct descrip *); -#endif /* FncTrace */ - - /* ExInterp not needed since no change since last EntInterp */ if (type == I_Vararg) { int (*bfunc)(); bfunc = bproc->entryp.ccode; - -#ifdef FncTrace - signal = (*bfunc)(nargs, rargp, &(procs->pname)); -#else /* FncTrace */ signal = (*bfunc)(nargs,rargp); -#endif /* FncTrace */ - } else { int (*bfunc)(); bfunc = bproc->entryp.ccode; - -#ifdef FncTrace - signal = (*(bfunc2)bfunc)(rargp, &(bproc->pname)); -#else /* FncTrace */ signal = (*bfunc)(rargp); -#endif /* FncTrace */ - } - -#ifdef FncTrace - if (k_ftrace) { - k_ftrace--; - if (signal == A_Failure) - failtrace(&(bproc->pname)); - else - rtrace(&(bproc->pname),rargp); } -#endif /* FncTrace */ - goto C_rtn_term; } } @@ -781,19 +571,7 @@ invokej: case Op_Llist: /* construct list */ opnd = GetWord; - -#ifdef EventMon - lastev = E_Operator; - value_tmp.dword = D_Proc; - value_tmp.vword.bptr = (union block *)&mt_llist; - InterpEVValD(&value_tmp, E_Ocall); - rargp = (dptr)(rsp - 1) - opnd; - xargp = rargp; - ExInterp; -#else /* EventMon */ Setup_Arg(opnd); -#endif /* EventMon */ - { int i; for (i=1;i<=opnd;i++) @@ -840,13 +618,6 @@ mark0: break; case Op_Unmark: /* remove expression frame */ - -#ifdef EventMon - ExInterp; - vanq_bound(efp, gfp); - EntInterp; -#endif /* EventMon */ - gfp = efp->ef_gfp; rsp = (word *)efp - 1; @@ -858,12 +629,6 @@ Unmark_uw: --ilevel; ExInterp; - -#ifdef EventMon - EVVal(A_Unmark_uw, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ - return A_Unmark_uw; } @@ -972,13 +737,6 @@ Unmark_uw: * limit not been reached). */ *lval = *(dptr)(rsp - 1); - -#ifdef EventMon - ExInterp; - vanq_bound(efp, gfp); - EntInterp; -#endif /* EventMon */ - gfp = efp->ef_gfp; /* @@ -989,12 +747,6 @@ Lsusp_uw: if (efp->ef_ilevel < ilevel) { --ilevel; ExInterp; - -#ifdef EventMon - EVVal(A_Lsusp_uw, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ - return A_Lsusp_uw; } rsp = (word *)efp - 1; @@ -1016,13 +768,6 @@ Lsusp_uw: struct descrip tmp; dptr svalp; struct b_proc *sproc; - -#ifdef EventMon - value_tmp = *(dptr)(rsp - 1); /* argument */ - Deref(value_tmp); - InterpEVValD(&value_tmp, E_Psusp); -#endif /* EventMon */ - svalp = (dptr)(rsp - 1); if (Var(*svalp)) { ExInterp; @@ -1082,11 +827,6 @@ Lsusp_uw: * a saved state, switch environments. */ if (pfp->pf_scan != NULL) { - -#ifdef EventMon - InterpEVValD(&k_subject, E_Ssusp); -#endif /* EventMon */ - tmp = k_subject; k_subject = *pfp->pf_scan; *pfp->pf_scan = tmp; @@ -1096,14 +836,6 @@ Lsusp_uw: k_pos = IntVal(tmp); } -#ifdef MultiThread - /* - * If the program state changed for this procedure call, - * change back. - */ - ENTERPSTATE(pfp->pf_prog); -#endif /* MultiThread */ - efp = pfp->pf_efp; ipc = pfp->pf_ipc; glbl_argp = pfp->pf_argp; @@ -1132,12 +864,6 @@ Eret_uw: if (efp->ef_ilevel < ilevel) { --ilevel; ExInterp; - -#ifdef EventMon - EVVal(A_Eret_uw, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ - return A_Eret_uw; } rsp = (word *)efp - 1; @@ -1148,11 +874,6 @@ Eret_uw: case Op_Pret: { /* return from procedure */ -#ifdef EventMon - struct descrip oldargp; - static struct descrip unwinder; -#endif /* EventMon */ - /* * An Icon procedure is returning a value. Determine if the * value being returned should be dereferenced and if so, @@ -1163,14 +884,6 @@ Eret_uw: */ struct b_proc *rproc; rproc = (struct b_proc *)BlkLoc(*glbl_argp); -#ifdef EventMon - oldargp = *glbl_argp; - ExInterp; - vanq_proc(efp, gfp); - EntInterp; - /* used to InterpEVValD(argp,E_Pret); here */ -#endif /* EventMon */ - *glbl_argp = *(dptr)(rsp - 1); if (Var(*glbl_argp)) { ExInterp; @@ -1187,20 +900,9 @@ Pret_uw: if (pfp->pf_ilevel < ilevel) { --ilevel; ExInterp; - -#ifdef EventMon - EVVal(A_Pret_uw, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); - unwinder = oldargp; -#endif /* EventMon */ - return A_Pret_uw; } -#ifdef EventMon - if (!is:proc(oldargp) && is:proc(unwinder)) - oldargp = unwinder; -#endif /* EventMon */ rsp = (word *)glbl_argp + 1; efp = pfp->pf_efp; gfp = pfp->pf_gfp; @@ -1208,15 +910,6 @@ Pret_uw: glbl_argp = pfp->pf_argp; pfp = pfp->pf_pfp; -#ifdef MultiThread - if (pfp) - ENTERPSTATE(pfp->pf_prog); -#ifdef EventMon - value_tmp = *(dptr)(rsp - 1); /* argument */ - Deref(value_tmp); - InterpEVValD(&value_tmp, E_Pret); -#endif /* EventMon */ -#endif /* MultiThread */ break; } @@ -1224,9 +917,6 @@ Pret_uw: case Op_Efail: efail: -#ifdef EventMon - InterpEVVal((word)-1, E_Efail); -#endif /* EventMon */ efail_noev: /* * Failure has occurred in the current expression frame. @@ -1243,12 +933,6 @@ efail_noev: * structures that fail when complete. */ -#ifdef MultiThread - if (efp == 0) { - break; - } -#endif /* MultiThread */ - ipc = efp->ef_failure; gfp = efp->ef_gfp; rsp = (word *)efp - 1; @@ -1298,58 +982,22 @@ efail_noev: tmp = *(pfp->pf_scan + 1); IntVal(*(pfp->pf_scan + 1)) = k_pos; k_pos = IntVal(tmp); - -#ifdef EventMon - InterpEVValD(&k_subject, E_Sresum); -#endif /* EventMon */ } -#ifdef MultiThread - /* - * Enter the program state of the resumed frame - */ - ENTERPSTATE(pfp->pf_prog); -#endif /* MultiThread */ - ++k_level; /* adjust procedure level */ } switch (type) { -#ifdef EventMon - case G_Fsusp: - InterpEVVal((word)0, E_Fresum); - --ilevel; - ExInterp; - EVVal(A_Resume, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); - return A_Resume; - - case G_Osusp: - InterpEVVal((word)0, E_Oresum); - --ilevel; - ExInterp; - EVVal(A_Resume, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); - return A_Resume; -#endif /* EventMon */ - case G_Csusp: - InterpEVVal((word)0, E_Eresum); --ilevel; ExInterp; -#ifdef EventMon - EVVal(A_Resume, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ return A_Resume; case G_Esusp: - InterpEVVal((word)0, E_Eresum); goto efail_noev; case G_Psusp: /* resuming a procedure */ - InterpEVValD(glbl_argp, E_Presum); break; } @@ -1357,14 +1005,6 @@ efail_noev: } case Op_Pfail: { /* fail from procedure */ - -#ifdef EventMon - ExInterp; - vanq_proc(efp, gfp); - EVValD(glbl_argp, E_Pfail); - EntInterp; -#endif /* EventMon */ - /* * An Icon procedure is failing. Generate tracing message if * tracing is on. Deactivate inactive C generators created @@ -1382,10 +1022,6 @@ Pfail_uw: if (pfp->pf_ilevel < ilevel) { --ilevel; ExInterp; -#ifdef EventMon - EVVal(A_Pfail_uw, E_Intret); - EVVal(DiffPtrs(sp, stack), E_Stack); -#endif /* EventMon */ return A_Pfail_uw; } efp = pfp->pf_efp; @@ -1393,17 +1029,6 @@ Pfail_uw: ipc = pfp->pf_ipc; glbl_argp = pfp->pf_argp; pfp = pfp->pf_pfp; - -#ifdef MultiThread - /* - * Enter the program state of the procedure being reentered. - * A NULL pfp indicates the program is complete. - */ - if (pfp) { - ENTERPSTATE(pfp->pf_prog); - } -#endif /* MultiThread */ - goto efail_noev; } /* ---Odds and Ends--- */ @@ -1478,12 +1103,6 @@ Pfail_uw: } goto mark0; -#ifdef TallyOpt - case Op_Tally: /* tally */ - tallybin[GetWord]++; - break; -#endif /* TallyOpt */ - case Op_Pnull: /* push null descriptor */ PushNull; break; @@ -1511,27 +1130,14 @@ Pfail_uw: /* ---Co-expressions--- */ case Op_Create: /* create */ - -#ifdef Coexpr PushNull; Setup_Arg(0); opnd = GetWord; opnd += (word)ipc.opnd; - signal = Ocreate((word *)opnd, rargp); - goto C_rtn_term; -#else /* Coexpr */ - err_msg(401, NULL); - goto efail; -#endif /* Coexpr */ case Op_Coact: { /* @e */ - -#ifndef Coexpr - err_msg(401, NULL); - goto efail; -#else /* Coexpr */ struct b_coexpr *ncp; dptr dp; @@ -1553,15 +1159,10 @@ Pfail_uw: goto efail_noev; else rsp -= 2; -#endif /* Coexpr */ break; } case Op_Coret: { /* return from co-expression */ - -#ifndef Coexpr - syserr("co-expression return, but co-expressions not implemented"); -#else /* Coexpr */ struct b_coexpr *ncp; ExInterp; @@ -1570,16 +1171,11 @@ Pfail_uw: ++BlkLoc(k_current)->coexpr.size; co_chng(ncp, (dptr)&sp[-1], NULL, A_Coret, 1); EntInterp; -#endif /* Coexpr */ break; } case Op_Cofail: { /* fail from co-expression */ - -#ifndef Coexpr - syserr("co-expression failure, but co-expressions not implemented"); -#else /* Coexpr */ struct b_coexpr *ncp; ExInterp; @@ -1587,7 +1183,6 @@ Pfail_uw: co_chng(ncp, NULL, NULL, A_Cofail, 1); EntInterp; -#endif /* Coexpr */ break; } @@ -1600,8 +1195,8 @@ Pfail_uw: default: { char buf[50]; - sprintf(buf, "unimplemented opcode: %ld (0x%08x)\n", - (long)lastop, lastop); + sprintf(buf, "unimplemented opcode: %ld (0x%08lx)\n", + (long)lastop, (long)lastop); syserr(buf); } } @@ -1613,73 +1208,25 @@ C_rtn_term: switch (signal) { case A_Resume: -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)-1, - ((lastev == E_Function)? E_Ffail : E_Ofail)); - lastev = E_Misc; - } -#endif /* EventMon */ goto efail_noev; case A_Unmark_uw: /* unwind for unmark */ -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); - lastev = E_Misc; - } -#endif /* EventMon */ goto Unmark_uw; case A_Lsusp_uw: /* unwind for lsusp */ -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); - lastev = E_Misc; - } -#endif /* EventMon */ goto Lsusp_uw; case A_Eret_uw: /* unwind for eret */ -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); - lastev = E_Misc; - } -#endif /* EventMon */ goto Eret_uw; case A_Pret_uw: /* unwind for pret */ -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); - lastev = E_Misc; - } -#endif /* EventMon */ goto Pret_uw; case A_Pfail_uw: /* unwind for pfail */ -#ifdef EventMon - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVVal((word)0, ((lastev==E_Function) ? E_Frem:E_Orem)); - lastev = E_Misc; - } -#endif /* EventMon */ goto Pfail_uw; } rsp = (word *)rargp + 1; /* set rsp to result */ - -#ifdef EventMon -return_term: - value_tmp = *(dptr)(rsp - 1); /* argument */ - Deref(value_tmp); - if ((lastev == E_Function) || (lastev == E_Operator)) { - InterpEVValD(&value_tmp, ((lastev == E_Function) ? E_Fret:E_Oret)); - lastev = E_Misc; - } -#endif /* EventMon */ - continue; } @@ -1690,129 +1237,3 @@ interp_quit: /*NOTREACHED*/ return 0; /* avoid gcc warning */ } - -#ifdef EventMon -/* - * vanq_proc - monitor the removal of suspended operations from within - * a procedure. - */ -static void vanq_proc(efp_v, gfp_v) -struct ef_marker *efp_v; -struct gf_marker *gfp_v; - { - - if (is:null(curpstate->eventmask)) - return; - - /* - * Go through all the bounded expression of the procedure. - */ - while ((efp_v = vanq_bound(efp_v, gfp_v)) != NULL) { - gfp_v = efp_v->ef_gfp; - efp_v = efp_v->ef_efp; - } - } - -/* - * vanq_bound - monitor the removal of suspended operations from - * the current bounded expression and return the expression frame - * pointer for the bounded expression. - */ -static struct ef_marker *vanq_bound(efp_v, gfp_v) -struct ef_marker *efp_v; -struct gf_marker *gfp_v; - { - - if (is:null(curpstate->eventmask)) - return efp_v; - - while (gfp_v != 0) { /* note removal of suspended operations */ - switch ((int)gfp_v->gf_gentype) { - case G_Psusp: - EVValD(gfp_v->gf_argp, E_Prem); - break; - /* G_Fsusp and G_Osusp handled in-line during unwinding */ - case G_Esusp: - EVVal((word)0, E_Erem); - break; - } - - if (((int)gfp_v->gf_gentype) == G_Psusp) { - vanq_proc(gfp_v->gf_efp, gfp_v->gf_gfp); - efp_v = gfp_v->gf_pfp->pf_efp; /* efp before the call */ - gfp_v = gfp_v->gf_pfp->pf_gfp; /* gfp before the call */ - } - else { - efp_v = gfp_v->gf_efp; - gfp_v = gfp_v->gf_gfp; - } - } - - return efp_v; - } -#endif /* EventMon */ - -#ifdef MultiThread -/* - * activate some other co-expression from an arbitrary point in - * the interpreter. - */ -int mt_activate(tvalp,rslt,ncp) -dptr tvalp, rslt; -register struct b_coexpr *ncp; -{ - register struct b_coexpr *ccp = (struct b_coexpr *)BlkLoc(k_current); - int first, rv; - - dptr savedtvalloc = NULL; - /* - * Set activator in new co-expression. - */ - if (ncp->es_actstk == NULL) { - Protect(ncp->es_actstk = alcactiv(), { err_msg(0, NULL); exit(1); }); - /* - * If no one ever explicitly activates this co-expression, fail to - * the implicit activator. - */ - ncp->es_actstk->arec[0].activator = ccp; - first = 0; - } - else - first = 1; - - if(ccp->tvalloc) { - if (InRange(blkbase,ccp->tvalloc,blkfree)) { - fprintf(stderr, - "Multiprogram garbage collection disaster in mt_activate()!\n"); - fflush(stderr); - exit(1); - } - savedtvalloc = ccp->tvalloc; - } - - rv = co_chng(ncp, tvalp, rslt, A_MTEvent, first); - - if ((savedtvalloc != NULL) && (savedtvalloc != ccp->tvalloc)) { - fprintf(stderr,"averted co-expression disaster in activate\n"); - ccp->tvalloc = savedtvalloc; - } - - return rv; -} - - -/* - * activate the "&parent" co-expression from anywhere, if there is one - */ -void actparent(event) -int event; - { - struct progstate *parent = curpstate->parent; - - StrLen(parent->eventcode) = 1; - StrLoc(parent->eventcode) = (char *)&allchars[event & 0xFF]; - mt_activate(&(parent->eventcode), NULL, - (struct b_coexpr *)curpstate->parent->Mainhead); - } -#endif /* MultiThread */ -#endif /* !COMPILER */ diff --git a/src/runtime/invoke.r b/src/runtime/invoke.r index 87b9fd1..ab781af 100644 --- a/src/runtime/invoke.r +++ b/src/runtime/invoke.r @@ -1,148 +1,7 @@ /* - * invoke.r - contains invoke, apply + * invoke.r -- Perform setup for invocation. */ -#if COMPILER - -/* - * invoke - perform general invocation on a value. - */ -int invoke(nargs, args, rslt, succ_cont) -int nargs; -dptr args; -dptr rslt; -continuation succ_cont; - { - tended struct descrip callee; - struct b_proc *proc; - C_integer n; - - /* - * remove the operation being called from the argument list. - */ - deref(&args[0], &callee); - ++args; - nargs -= 1; - - if (is:proc(callee)) - return (*((struct b_proc *)BlkLoc(callee))->ccode)(nargs, args, rslt, - succ_cont); - else if (cnv:C_integer(callee, n)) { - if (n <= 0) - n += nargs + 1; - if (n <= 0 || n > nargs) - return A_Resume; - *rslt = args[n - 1]; - return A_Continue; - } - else if (cnv:string(callee, callee)) { - proc = strprc(&callee, (C_integer)nargs); - if (proc == NULL) - RunErr(106, &callee); - return (*(proc)->ccode)(nargs, args, rslt, succ_cont); - } - else - RunErr(106, &callee); - } - - -/* - * apply - implement binary bang. Construct an argument list for - * invoke() from the callee and the list it is applied to. - */ -int apply(callee, strct, rslt, succ_cont) -dptr callee; -dptr strct; -dptr rslt; -continuation succ_cont; - { - tended struct descrip dstrct; - struct tend_desc *tnd_args; /* place to tend arguments to invoke() */ - union block *ep; - int nargs; - word i, j; - word indx; - int signal; - - deref(strct, &dstrct); - - switch (Type(dstrct)) { - - case T_List: { - /* - * Copy the arguments from the list into an tended array of descriptors. - */ - nargs = BlkLoc(dstrct)->list.size + 1; - tnd_args = malloc(sizeof(struct tend_desc) - + (nargs - 1) * sizeof(struct descrip)); - if (tnd_args == NULL) - RunErr(305, NULL); - - tnd_args->d[0] = *callee; - indx = 1; - for (ep = BlkLoc(dstrct)->list.listhead; -#ifdef ListFix - BlkType(ep) == T_Lelem; -#else /* ListFix */ - ep != NULL; -#endif /* ListFix */ - ep = ep->lelem.listnext) { - for (i = 0; i < ep->lelem.nused; i++) { - j = ep->lelem.first + i; - if (j >= ep->lelem.nslots) - j -= ep->lelem.nslots; - tnd_args->d[indx++] = ep->lelem.lslots[j]; - } - } - tnd_args->num = nargs; - tnd_args->previous = tend; - tend = tnd_args; - - signal = invoke(indx, tnd_args->d, rslt, succ_cont); - - tend = tnd_args->previous; - free(tnd_args); - return signal; - } - case T_Record: { - /* - * Copy the arguments from the record into an tended array - * of descriptors. - */ - nargs = BlkLoc(dstrct)->record.recdesc->proc.nfields; - tnd_args = malloc(sizeof(struct tend_desc) - + (nargs - 1) * sizeof(struct descrip)); - if (tnd_args == NULL) - RunErr(305, NULL); - - tnd_args->d[0] = *callee; - indx = 1; - ep = BlkLoc(dstrct); - for (i = 0; i < nargs; i++) - tnd_args->d[indx++] = ep->record.fields[i]; - tnd_args->num = nargs; - tnd_args->previous = tend; - tend = tnd_args; - - signal = invoke(indx, tnd_args->d, rslt, succ_cont); - - tend = tnd_args->previous; - free(tnd_args); - return signal; - } - default: { - RunErr(126, &dstrct); - } - } - } - -#else /* COMPILER */ - -#ifdef EventMon -#include "../h/opdefs.h" -#endif /* EventMon */ - - /* * invoke -- Perform setup for invocation. */ @@ -294,15 +153,12 @@ int nargs, *n; *cargp = newargp; sp = newsp; - EVVal((word)Op_Invoke,E_Ecall); - if ((nparam < 0) || (proc->ndynam == -2)) return I_Vararg; else return I_Builtin; } -#ifndef MultiThread /* * Make a stab at catching interpreter stack overflow. This does * nothing for invocation in a co-expression other than &main. @@ -310,7 +166,6 @@ int nargs, *n; if (BlkLoc(k_current) == BlkLoc(k_main) && ((char *)sp + PerilDelta) > (char *)stackend) fatalerr(301, NULL); -#endif /* MultiThread */ /* * Build the procedure frame. @@ -326,10 +181,6 @@ int nargs, *n; newpfp->pf_gfp = gfp; newpfp->pf_efp = efp; -#ifdef MultiThread - newpfp->pf_prog = curpstate; -#endif /* MultiThread */ - glbl_argp = newargp; pfp = newpfp; newsp += Vwsizeof(*pfp); @@ -347,15 +198,6 @@ int nargs, *n; */ ipc.opnd = (word *)proc->entryp.icode; -#ifdef MultiThread - /* - * Enter the program state of the procedure being invoked. - */ - if (!InRange(code, ipc.opnd, ecode)) { - syserr("interprogram procedure calls temporarily prohibited\n"); - } -#endif /* MultiThread */ - efp = 0; gfp = 0; @@ -369,9 +211,5 @@ int nargs, *n; sp = newsp; k_level++; - EVValD(newargp, E_Pcall); - return I_Continue; } - -#endif /* COMPILER */ diff --git a/src/runtime/keyword.r b/src/runtime/keyword.r index e6eb462..9e92607 100644 --- a/src/runtime/keyword.r +++ b/src/runtime/keyword.r @@ -55,25 +55,15 @@ keyword{4} collections } end -#if !COMPILER "&column - source column number of current execution point" keyword{1} column abstract { return integer; } inline { -#ifdef MultiThread -#ifdef EventMon - return C_integer findcol(ipc.opnd); -#else /* EventMon */ fail; -#endif /* EventMon */ -#else - fail; -#endif /* MultiThread */ } end -#endif /* !COMPILER */ "¤t - the currently active co-expression" keyword{1} current @@ -259,11 +249,7 @@ keyword{1,*} features return string } body { -#if COMPILER -#define Feature(guard,sym,kwval) if ((guard) && (kwval)) suspend C_string kwval; -#else /* COMPILER */ #define Feature(guard,sym,kwval) if (kwval) suspend C_string kwval; -#endif /* COMPILER */ #include "../h/features.h" fail; } @@ -275,17 +261,10 @@ keyword{1} file return string } inline { -#if COMPILER - if (line_info) - return C_string file_name; - else - runerr(402); -#else /* COMPILER */ char *s; s = findfile(ipc.opnd); if (!strcmp(s,"?")) fail; return C_string s; -#endif /* COMPILER */ } end @@ -332,10 +311,6 @@ keyword{1} level } inline { -#if COMPILER - if (!debug_info) - runerr(402); -#endif /* COMPILER */ return C_integer k_level; } end @@ -346,14 +321,7 @@ keyword{1} line return integer; } inline { -#if COMPILER - if (line_info) - return C_integer line_num; - else - runerr(402); -#else /* COMPILER */ return C_integer findline(ipc.opnd); -#endif /* COMPILER */ } end @@ -460,11 +428,7 @@ keyword{1} source return coexpr } inline { -#ifndef Coexpr - return k_main; -#else /* Coexpr */ return coexpr(topact((struct b_coexpr *)BlkLoc(k_current))); -#endif /* Coexpr */ } end @@ -545,9 +509,7 @@ keyword{1} version constant Version end -#ifndef MultiThread struct descrip kywd_xwin[2] = {{D_Null}}; -#endif /* MultiThread */ "&window - variable containing the current graphics rendering context." #ifdef Graphics diff --git a/src/runtime/lmisc.r b/src/runtime/lmisc.r index 11f29de..52f0a6d 100644 --- a/src/runtime/lmisc.r +++ b/src/runtime/lmisc.r @@ -6,86 +6,48 @@ /* * create - return an entry block for a co-expression. */ -#if COMPILER -struct b_coexpr *create(fnc, cproc, ntemps, wrk_size) -continuation fnc; -struct b_proc *cproc; -int ntemps; -int wrk_size; -#else /* COMPILER */ int Ocreate(entryp, cargp) word *entryp; register dptr cargp; -#endif /* COMPILER */ { - -#ifdef Coexpr tended struct b_coexpr *sblkp; register struct b_refresh *rblkp; register dptr dp, ndp; int na, nl, i; - -#if !COMPILER struct b_proc *cproc; /* cproc is the Icon procedure that create occurs in */ cproc = (struct b_proc *)BlkLoc(glbl_argp[0]); -#endif /* COMPILER */ /* * Calculate number of arguments and number of local variables. */ -#if COMPILER - na = abs((int)cproc->nparam); -#else /* COMPILER */ na = pfp->pf_nargs + 1; /* includes Arg0 */ -#endif /* COMPILER */ nl = (int)cproc->ndynam; /* * Get a new co-expression stack and initialize. */ - -#ifdef MultiThread - Protect(sblkp = alccoexp(0, 0), err_msg(0, NULL)); -#else /* MultiThread */ Protect(sblkp = alccoexp(), err_msg(0, NULL)); -#endif /* MultiThread */ - - if (!sblkp) -#if COMPILER - return NULL; -#else /* COMPILER */ Fail; -#endif /* COMPILER */ /* * Get a refresh block for the new co-expression. */ -#if COMPILER - Protect(rblkp = alcrefresh(na, nl, ntemps, wrk_size), err_msg(0,NULL)); -#else /* COMPILER */ Protect(rblkp = alcrefresh(entryp, na, nl),err_msg(0,NULL)); -#endif /* COMPILER */ if (!rblkp) -#if COMPILER - return NULL; -#else /* COMPILER */ Fail; -#endif /* COMPILER */ sblkp->freshblk.dword = D_Refresh; BlkLoc(sblkp->freshblk) = (union block *) rblkp; -#if !COMPILER /* * Copy current procedure frame marker into refresh block. */ rblkp->pfmkr = *pfp; rblkp->pfmkr.pf_pfp = 0; -#endif /* COMPILER */ /* * Copy arguments into refresh block. @@ -98,11 +60,7 @@ register dptr cargp; /* * Copy locals into the refresh block. */ -#if COMPILER - dp = pfp->tend.d; -#else /* COMPILER */ dp = &(pfp->pf_locals)[0]; -#endif /* COMPILER */ for (i = 1; i <= nl; i++) *ndp++ = *dp++; @@ -111,33 +69,12 @@ register dptr cargp; */ co_init(sblkp); -#if COMPILER - sblkp->fnc = fnc; - if (line_info) { - if (debug_info) - PFDebug(sblkp->pf)->proc = cproc; - PFDebug(sblkp->pf)->old_fname = ""; - PFDebug(sblkp->pf)->old_line = 0; - } - - return sblkp; -#else /* COMPILER */ /* * Return the new co-expression. */ Arg0.dword = D_Coexpr; BlkLoc(Arg0) = (union block *) sblkp; Return; -#endif /* COMPILER */ -#else /* Coexpr */ - err_msg(401, NULL); -#if COMPILER - return NULL; -#else /* COMPILER */ - Fail; -#endif /* COMPILER */ -#endif /* Coexpr */ - } /* @@ -148,8 +85,6 @@ dptr val; struct b_coexpr *ncp; dptr result; { -#ifdef Coexpr - int first; /* @@ -169,8 +104,4 @@ dptr result; return A_Resume; else return A_Continue; - -#else /* Coexpr */ - RunErr(401,NULL); -#endif /* Coexpr */ } diff --git a/src/runtime/oarith.r b/src/runtime/oarith.r index b3ca88c..7d0978f 100644 --- a/src/runtime/oarith.r +++ b/src/runtime/oarith.r @@ -13,9 +13,7 @@ int over_flow = 0; operator{1} icon_op func_name(x, y) declare { -#ifdef LargeInts tended struct descrip lx, ly; -#endif /* LargeInts */ C_integer irslt; } arith_case (x, y) of { @@ -70,15 +68,11 @@ end irslt = div3(x,y); if (over_flow) { -#ifdef LargeInts MakeInt(x,&lx); MakeInt(y,&ly); if (bigdiv(&lx,&ly,&result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - runerr(203); -#endif /* LargeInts */ } else return C_integer irslt; } @@ -112,15 +106,11 @@ ArithOp( / , divide , Divide , RealDivide) #begdef Sub(x,y) irslt = sub(x,y); if (over_flow) { -#ifdef LargeInts MakeInt(x,&lx); MakeInt(y,&ly); if (bigsub(&lx,&ly,&result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - runerr(203); -#endif /* LargeInts */ } else return C_integer irslt; #enddef @@ -196,15 +186,11 @@ ArithOp( % , mod , IntMod , RealMod) #begdef Mpy(x,y) irslt = mul(x,y); if (over_flow) { -#ifdef LargeInts MakeInt(x,&lx); MakeInt(y,&ly); if (bigmul(&lx,&ly,&result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - runerr(203); -#endif /* LargeInts */ } else return C_integer irslt; #enddef @@ -228,21 +214,15 @@ operator{1} - neg(x) i = neg(x); if (over_flow) { -#ifdef LargeInts struct descrip tmp; MakeInt(x,&tmp); if (bigneg(&tmp, &result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - irunerr(203,x); - errorfail; -#endif /* LargeInts */ } return C_integer i; } } -#ifdef LargeInts else if cnv:(exact) integer(x) then { abstract { return integer @@ -253,7 +233,6 @@ operator{1} - neg(x) return result; } } -#endif /* LargeInts */ else { if !cnv:C_double(x) then runerr(102, x) @@ -282,7 +261,6 @@ operator{1} + number(x) return C_integer x; } } -#ifdef LargeInts else if cnv:(exact) integer(x) then { abstract { return integer @@ -291,7 +269,6 @@ operator{1} + number(x) return x; } } -#endif /* LargeInts */ else if cnv:C_double(x) then { abstract { return real @@ -319,15 +296,11 @@ end #begdef Add(x,y) irslt = add(x,y); if (over_flow) { -#ifdef LargeInts MakeInt(x,&lx); MakeInt(y,&ly); if (bigadd(&lx, &ly, &result) == Error) /* alcbignum failed */ runerr(0); return result; -#else /* LargeInts */ - runerr(203); -#endif /* LargeInts */ } else return C_integer irslt; #enddef @@ -346,19 +319,11 @@ operator{1} ^ powr(x, y) return integer } inline { -#ifdef LargeInts tended struct descrip ly; MakeInt ( y, &ly ); if (bigpow(&x, &ly, &result) == Error) /* alcbignum failed */ runerr(0); return result; -#else - extern int over_flow; - C_integer r = iipow(IntVal(x), y); - if (over_flow) - runerr(203); - return C_integer r; -#endif } } else { @@ -374,7 +339,6 @@ operator{1} ^ powr(x, y) } } } -#ifdef LargeInts else if cnv:(exact)integer(y) then { if cnv:(exact)integer(x) then { abstract { @@ -399,7 +363,6 @@ operator{1} ^ powr(x, y) } } } -#endif /* LargeInts */ else { if !cnv:C_double(x) then runerr(102, x) @@ -418,52 +381,6 @@ operator{1} ^ powr(x, y) } end -#if COMPILER || !(defined LargeInts) -/* - * iipow - raise an integer to an integral power. - */ -C_integer iipow(n1, n2) -C_integer n1, n2; - { - C_integer result; - - /* Handle some special cases first */ - over_flow = 0; - switch ( n1 ) { - case 1: - return 1; - case -1: - /* Result depends on whether n2 is even or odd */ - return ( n2 & 01 ) ? -1 : 1; - case 0: - if ( n2 <= 0 ) - over_flow = 1; - return 0; - default: - if (n2 < 0) - return 0; - } - - result = 1L; - for ( ; ; ) { - if (n2 & 01L) - { - result = mul(result, n1); - if (over_flow) - return 0; - } - - if ( ( n2 >>= 1 ) == 0 ) break; - n1 = mul(n1, n1); - if (over_flow) - return 0; - } - over_flow = 0; - return result; - } -#endif /* COMPILER || !(defined LargeInts) */ - - /* * ripow - raise a real number to an integral power. */ diff --git a/src/runtime/oasgn.r b/src/runtime/oasgn.r index b93d646..0b25c1d 100644 --- a/src/runtime/oasgn.r +++ b/src/runtime/oasgn.r @@ -14,15 +14,6 @@ */ #begdef GeneralAsgn(x, y) -#ifdef EventMon - body { - if (!is:null(curpstate->eventmask) && - Testb((word)E_Assign, curpstate->eventmask)) { - EVAsgn(&x); - } - } -#endif /* EventMon */ - type_case x of { tvsubs: { abstract { @@ -85,18 +76,10 @@ if (!cnv:C_integer(y, i)) runerr(101, y); - -#ifdef MultiThread - i = cvpos((long)i, StrLen(*(VarLoc(x)+1))); -#else /* MultiThread */ i = cvpos((long)i, StrLen(k_subject)); -#endif /* MultiThread */ - if (i == CvtFail) fail; IntVal(*VarLoc(x)) = i; - - EVVal(k_pos, E_Spos); } } kywdsubj: { @@ -107,12 +90,7 @@ if !cnv:string(y, *VarLoc(x)) then runerr(103, y); inline { -#ifdef MultiThread - IntVal(*(VarLoc(x)-1)) = 1; -#else /* MultiThread */ k_pos = 1; -#endif /* MultiThread */ - EVVal(k_pos, E_Spos); } } kywdstr: { @@ -132,12 +110,6 @@ } } -#ifdef EventMon - body { - EVValD(&y, E_Value); - } -#endif /* EventMon */ - #enddef @@ -460,8 +432,6 @@ const dptr src; } } tvsub->sslen = StrLen(srcstr); - - EVVal(tvsub->sslen, E_Ssasgn); return Succeeded; } diff --git a/src/runtime/ocat.r b/src/runtime/ocat.r index c778d6d..80f0e82 100644 --- a/src/runtime/ocat.r +++ b/src/runtime/ocat.r @@ -101,9 +101,6 @@ operator{1} ||| lconcat(x, y) Protect(bp1 = (struct b_list *)alclist(size3), runerr(0)); Protect(lp1 = (struct b_lelem *)alclstb(size3,(word)0,size3), runerr(0)); bp1->listhead = bp1->listtail = (union block *)lp1; -#ifdef ListFix - lp1->listprev = lp1->listnext = (union block *)bp1; -#endif /* ListFix */ /* * Make a copy of both lists in adjacent slots. @@ -112,9 +109,6 @@ operator{1} ||| lconcat(x, y) cpslots(&y, lp1->lslots + size1, (word)1, size2 + 1); BlkLoc(x) = (union block *)bp1; - - EVValD(&x, E_Lcreate); - return x; } end diff --git a/src/runtime/omisc.r b/src/runtime/omisc.r index 96a3e1b..4c11678 100644 --- a/src/runtime/omisc.r +++ b/src/runtime/omisc.r @@ -4,7 +4,6 @@ */ "^x - create a refreshed copy of a co-expression." -#ifdef Coexpr /* * ^x - return an entry block for co-expression x from the refresh block. */ @@ -21,12 +20,7 @@ operator{1} ^ refresh(x) /* * Get a new co-expression stack and initialize. */ -#ifdef MultiThread - Protect(sblkp = alccoexp(0, 0), runerr(0)); -#else /* MultiThread */ Protect(sblkp = alccoexp(), runerr(0)); -#endif /* MultiThread */ - sblkp->freshblk = BlkLoc(x)->coexpr.freshblk; if (ChkNull(sblkp->freshblk)) /* &main cannot be refreshed */ runerr(215, x); @@ -35,26 +29,8 @@ operator{1} ^ refresh(x) * Use refresh block to finish initializing the new co-expression. */ co_init(sblkp); - -#if COMPILER - sblkp->fnc = BlkLoc(x)->coexpr.fnc; - if (line_info) { - if (debug_info) - PFDebug(sblkp->pf)->proc = PFDebug(BlkLoc(x)->coexpr.pf)->proc; - PFDebug(sblkp->pf)->old_fname = - PFDebug(BlkLoc(x)->coexpr.pf)->old_fname; - PFDebug(sblkp->pf)->old_line = - PFDebug(BlkLoc(x)->coexpr.pf)->old_line; - } -#endif /* COMPILER */ - return coexpr(sblkp); } -#else /* Coexpr */ -operator{} ^ refresh(x) - runerr(401) -#endif /* Coexpr */ - end @@ -151,9 +127,6 @@ operator{*} = tabmat(x) */ l = StrLen(x); k_pos += l; - - EVVal(k_pos, E_Spos); - suspend x; /* @@ -161,10 +134,8 @@ operator{*} = tabmat(x) */ if (i > StrLen(k_subject) + 1) runerr(205, kywd_pos); - else { + else k_pos = i; - EVVal(k_pos, E_Spos); - } fail; } end @@ -265,9 +236,6 @@ operator{1} [...] llist(elems[n]) * for the list. */ hp->listhead = hp->listtail = (union block *)bp; -#ifdef ListFix - bp->listprev = bp->listnext = (union block *)hp; -#endif /* ListFix */ /* * Assign each argument to a list element. @@ -275,9 +243,6 @@ operator{1} [...] llist(elems[n]) for (i = 0; i < n; i++) bp->lslots[i] = elems[i]; -/* Not quite right -- should be after list() returns in case it fails */ - Desc_EVValD(hp, E_Lcreate, D_List); - return list(hp); } end diff --git a/src/runtime/oref.r b/src/runtime/oref.r index 3ac86bc..8e1ffea 100644 --- a/src/runtime/oref.r +++ b/src/runtime/oref.r @@ -38,35 +38,18 @@ operator{*} ! bang(underef x -> dx) return type(dx).lst_elem } inline { - -#ifdef EventMon - word xi = 0; - - EVValD(&dx, E_Lbang); -#endif /* EventMon */ - /* * x is a list. Chain through each list element block and for * each one, suspend with a variable pointing to each * element contained in the block. */ for (ep = BlkLoc(dx)->list.listhead; -#ifdef ListFix - BlkType(ep) == T_Lelem; -#else /* ListFix */ ep != NULL; -#endif /* ListFix */ ep = ep->lelem.listnext){ for (i = 0; i < ep->lelem.nused; i++) { j = ep->lelem.first + i; if (j >= ep->lelem.nslots) j -= ep->lelem.nslots; - -#ifdef EventMon - MakeInt(++xi, &eventdesc); - EVValD(&eventdesc, E_Lsub); -#endif /* EventMon */ - suspend struct_var(&ep->lelem.lslots[j], ep); } } @@ -158,17 +141,12 @@ operator{*} ! bang(underef x -> dx) inline { struct b_tvtbl *tp; - EVValD(&dx, E_Tbang); - /* * x is a table. Chain down the element list in each bucket * and suspend a variable pointing to each element in turn. */ for (ep = hgfirst(BlkLoc(dx), &state); ep != 0; ep = hgnext(BlkLoc(dx), &state, ep)) { - - EVValD(&ep->telem.tval, E_Tval); - Protect(tp = alctvtbl(&dx, &ep->telem.tref, ep->telem.hashnum), runerr(0)); suspend tvtbl(tp); } @@ -180,14 +158,12 @@ operator{*} ! bang(underef x -> dx) return store[type(dx).set_elem] } inline { - EVValD(&dx, E_Sbang); /* * This is similar to the method for tables except that a * value is returned instead of a variable. */ for (ep = hgfirst(BlkLoc(dx), &state); ep != 0; ep = hgnext(BlkLoc(dx), &state, ep)) { - EVValD(&ep->selem.setmem, E_Sval); suspend ep->selem.setmem; } } @@ -202,21 +178,8 @@ operator{*} ! bang(underef x -> dx) * x is a record. Loop through the fields and suspend * a variable pointing to each one. */ - -#ifdef EventMon - word xi = 0; - - EVValD(&dx, E_Rbang); -#endif /* EventMon */ - j = BlkLoc(dx)->record.recdesc->proc.nfields; for (i = 0; i < j; i++) { - -#ifdef EventMon - MakeInt(++xi, &eventdesc); - EVValD(&eventdesc, E_Rsub); -#endif /* EventMon */ - suspend struct_var(&BlkLoc(dx)->record.fields[i], (struct b_record *)BlkLoc(dx)); } @@ -256,12 +219,6 @@ end operator{0,1} ? random(underef x -> dx) -#ifndef LargeInts - declare { - C_integer v = 0; - } -#endif /* LargeInts */ - if is:variable(x) && is:string(dx) then { abstract { return new tvsubs(type(x)) @@ -347,13 +304,6 @@ operator{0,1} ? random(underef x -> dx) rval = RandVal; rval *= val; i = (word)rval + 1; - -#ifdef EventMon - EVValD(&dx, E_Lrand); - MakeInt(i, &eventdesc); - EVValD(&eventdesc, E_Lsub); -#endif /* EventMon */ - j = 1; /* * Work down chain list of list blocks and find the block that @@ -363,11 +313,7 @@ operator{0,1} ? random(underef x -> dx) while (i >= j + bp->lelem.nused) { j += bp->lelem.nused; bp = bp->lelem.listnext; -#ifdef ListFix - if (BlkType(bp) == T_List) -#else /* ListFix */ if (bp == NULL) -#endif /* ListFix */ syserr("list reference out of bounds in random"); } /* @@ -405,13 +351,6 @@ operator{0,1} ? random(underef x -> dx) rval *= val; n = (word)rval + 1; -#ifdef EventMon - EVValD(&dx, E_Trand); - MakeInt(n, &eventdesc); - EVValD(&eventdesc, E_Tsub); -#endif /* EventMon */ - - /* * Walk down the hash chains to find and return the nth element * as a variable. @@ -419,11 +358,7 @@ operator{0,1} ? random(underef x -> dx) for (i = 0; i < HSegs && (seg = bp->table.hdir[i]) != NULL; i++) for (j = segsize[i] - 1; j >= 0; j--) for (ep = seg->hslots[j]; -#ifdef TableFix - BlkType(ep) == T_Telem; -#else /* TableFix */ ep != NULL; -#endif /* TableFix */ ep = ep->telem.clink) if (--n <= 0) { Protect(tp = alctvtbl(&dx, &ep->telem.tref, ep->telem.hashnum), runerr(0)); @@ -456,11 +391,6 @@ operator{0,1} ? random(underef x -> dx) rval *= val; n = (word)rval + 1; -#ifdef EventMon - EVValD(&dx, E_Srand); - MakeInt(n, &eventdesc); -#endif /* EventMon */ - /* * Walk down the hash chains to find and return the nth element. */ @@ -497,43 +427,27 @@ operator{0,1} ? random(underef x -> dx) */ rval = RandVal; rval *= val; - -#ifdef EventMon - EVValD(&dx, E_Rrand); - MakeInt(rval + 1, &eventdesc); - EVValD(&eventdesc, E_Rsub); -#endif /* EventMon */ - return struct_var(&rec->fields[(word)rval], rec); } } default: { -#ifdef LargeInts if !cnv:integer(dx) then runerr(113, dx) -#else /* LargeInts */ - if !cnv:C_integer(dx,v) then - runerr(113, dx) -#endif /* LargeInts */ - abstract { return integer ++ real } body { double rval; - -#ifdef LargeInts C_integer v; if (Type(dx) == T_Lrgint) { if (bigrand(&dx, &result) == Error) /* alcbignum failed */ runerr(0); return result; } - v = IntVal(dx); -#endif /* LargeInts */ + /* * x is an integer, be sure that it's non-negative. */ @@ -690,12 +604,6 @@ operator{0,1} [] subsc(underef x -> dx,y) register union block *bp; /* doesn't need to be tended */ struct b_list *lp; /* doesn't need to be tended */ -#ifdef EventMon - EVValD(&dx, E_Lref); - MakeInt(y, &eventdesc); - EVValD(&eventdesc, E_Lsub); -#endif /* EventMon */ - /* * Make sure that subscript y is in range. */ @@ -742,9 +650,6 @@ operator{0,1} [] subsc(underef x -> dx,y) uword hn; struct b_tvtbl *tp; - EVValD(&dx, E_Tref); - EVValD(&y, E_Tsub); - hn = hash(&y); Protect(tp = alctvtbl(&dx, &y, hn), runerr(0)); return tvtbl(tp); @@ -777,13 +682,6 @@ operator{0,1} [] subsc(underef x -> dx,y) for(i=0; i<nf; i++) { if (len == StrLen(bp2->proc.lnames[i]) && !strncmp(loc, StrLoc(bp2->proc.lnames[i]), len)) { - -#ifdef EventMon - EVValD(&dx, E_Rref); - MakeInt(i+1, &eventdesc); - EVValD(&eventdesc, E_Rsub); -#endif /* EventMon */ - /* * Found the field, return a pointer to it. */ @@ -802,13 +700,6 @@ operator{0,1} [] subsc(underef x -> dx,y) i = cvpos(y, (word)(bp->record.recdesc->proc.nfields)); if (i == CvtFail || i > bp->record.recdesc->proc.nfields) fail; - -#ifdef EventMon - EVValD(&dx, E_Rref); - MakeInt(i, &eventdesc); - EVValD(&eventdesc, E_Rsub); -#endif /* EventMon */ - /* * Locate the appropriate field and return a pointer to it. */ diff --git a/src/runtime/oset.r b/src/runtime/oset.r index 7808e80..dc8e126 100644 --- a/src/runtime/oset.r +++ b/src/runtime/oset.r @@ -84,7 +84,6 @@ operator{1} -- diff(x,y) deallocate((union block *)np); if (TooSparse(dstp)) hshrink(dstp); - Desc_EVValD(dstp, E_Screate, D_Set); return set(dstp); } } @@ -175,7 +174,6 @@ operator{1} ** inter(x,y) deallocate((union block *)np); if (TooSparse(dstp)) hshrink(dstp); - Desc_EVValD(dstp, E_Screate, D_Set); return set(dstp); } } diff --git a/src/runtime/ralc.r b/src/runtime/ralc.r index 9f55671..403515b 100644 --- a/src/runtime/ralc.r +++ b/src/runtime/ralc.r @@ -11,12 +11,11 @@ static struct region *newregion (word nbytes, word stdsize); extern word alcnum; -#ifndef MultiThread word coexp_ser = 2; /* serial numbers for co-expressions; &main is 1 */ +word extl_ser = 1; /* serial numbers for externals */ word list_ser = 1; /* serial numbers for lists */ word set_ser = 1; /* serial numbers for sets */ word table_ser = 1; /* serial numbers for tables */ -#endif /* MultiThread */ /* @@ -24,10 +23,6 @@ word table_ser = 1; /* serial numbers for tables */ */ #begdef AlcBlk(var, struct_nm, t_code, nbytes) { -#ifdef MultiThread - EVVal((word)nbytes, typech[t_code]); -#endif /* MultiThread */ - /* * Ensure that there is enough room in the block region. */ @@ -35,13 +30,6 @@ word table_ser = 1; /* serial numbers for tables */ return NULL; /* - * If monitoring, show the allocation. - */ -#ifndef MultiThread - EVVal((word)nbytes, typech[t_code]); -#endif - - /* * Decrement the free space in the block region by the number of bytes * allocated and return the address of the first byte of the allocated * block. @@ -64,11 +52,7 @@ word table_ser = 1; /* serial numbers for tables */ */ #begdef AlcVarBlk(var, struct_nm, t_code, n_desc) { -#ifdef EventMon - uword size; -#else /* EventMon */ register uword size; -#endif /* EventMon */ /* * Variable size blocks are declared with one descriptor, thus @@ -105,7 +89,6 @@ struct astkblk *alcactiv() return abp; } -#ifdef LargeInts /* * alcbignum - allocate an n-digit bignum in the block region */ @@ -125,17 +108,18 @@ word n; blk->lsd = n - 1; return blk; } -#endif /* LargeInts */ /* * alccoexp - allocate a co-expression stack block. + * + * Although pthreads allocates a C stack, we still need this an + * interpreter stack beyond the end of the coexpr block. */ -#if COMPILER struct b_coexpr *alccoexp() { struct b_coexpr *ep; - static int serial = 2; /* main co-expression is allocated elsewhere */ + ep = (struct b_coexpr *)malloc(stksize); /* @@ -146,112 +130,24 @@ struct b_coexpr *alccoexp() if (ep == NULL || alcnum > AlcMax) { collect(Static); ep = (struct b_coexpr *)malloc(stksize); - } - + } if (ep == NULL) ReturnErrNum(305, NULL); - alcnum++; /* increment allocation count since last g.c. */ - - ep->title = T_Coexpr; - ep->size = 0; - ep->id = serial++; - ep->nextstk = stklist; - ep->es_tend = NULL; - ep->file_name = ""; - ep->line_num = 0; - ep->freshblk = nulldesc; - ep->es_actstk = NULL; - ep->cstate[0] = 0; /* zero the first two cstate words as a flag */ - ep->cstate[1] = 0; - stklist = ep; - return ep; - } -#else /* COMPILER */ -#ifdef MultiThread -/* - * If this is a new program being loaded, an icodesize>0 gives the - * hdr.hsize and a stacksize to use; allocate - * sizeof(progstate) + icodesize + mstksize - * Otherwise (icodesize==0), allocate a normal stksize... - */ -struct b_coexpr *alccoexp(icodesize, stacksize) -long icodesize, stacksize; -#else /* MultiThread */ -struct b_coexpr *alccoexp() -#endif /* MultiThread */ - - { - struct b_coexpr *ep; - -#ifdef MultiThread - if (icodesize > 0) { - ep = (struct b_coexpr *) - calloc(1, stacksize+ - icodesize+ - sizeof(struct progstate)+ - sizeof(struct b_coexpr)); - } - else -#endif /* MultiThread */ - - ep = (struct b_coexpr *)malloc(stksize); - - /* - * If malloc failed or if there have been too many co-expression allocations - * since a collection, attempt to free some co-expression blocks and retry. - */ - - if (ep == NULL || alcnum > AlcMax) { - - collect(Static); - -#ifdef MultiThread - if (icodesize>0) { - ep = (struct b_coexpr *) - malloc(mstksize+icodesize+sizeof(struct progstate)); - } - else -#endif /* MultiThread */ - - ep = (struct b_coexpr *)malloc(stksize); - } - if (ep == NULL) - ReturnErrNum(305, NULL); - alcnum++; /* increment allocation count since last g.c. */ ep->title = T_Coexpr; ep->es_actstk = NULL; ep->size = 0; -#ifdef MultiThread - ep->es_pfp = NULL; - ep->es_gfp = NULL; - ep->es_argp = NULL; - ep->tvalloc = NULL; - - if (icodesize > 0) - ep->id = 1; - else -#endif /* MultiThread */ ep->id = coexp_ser++; ep->nextstk = stklist; ep->es_tend = NULL; ep->cstate[0] = 0; /* zero the first two cstate words as a flag */ ep->cstate[1] = 0; -#ifdef MultiThread - /* - * Initialize program state to self for &main; curpstate for others. - */ - if(icodesize>0) ep->program = (struct progstate *)(ep+1); - else ep->program = curpstate; -#endif /* MultiThread */ - stklist = ep; return ep; } -#endif /* COMPILER */ /* * alccset - allocate a cset in the block region. @@ -274,6 +170,46 @@ struct b_cset *alccset() } /* + * alcexternal - allocate an external data block in the block region. + * + * nbytes is total struct size including header, or zero to use default + * f is dispatch table of user C functions; also differentiates external types + * data is copied in to initialize the data block. + * Any of these can be zero/null for default behavior. + * + * May cause a garbage collection. Returns null if still unsuccessful. + */ + +struct b_external *alcexternal(long nbytes, struct b_extlfuns *f, void *data) + { + register struct b_external *blk; + long datasize; + static struct b_extlfuns fdefault; /* default dispatch table, all empty */ + + if (nbytes == 0) + nbytes = sizeof(struct b_external); + + /* datasize = nbytes - offsetof(struct b_external, data); */ + datasize = nbytes - ((char*)blk->data - (char*)blk); + if (datasize < 0) + syserr("alcexternal: invalid size"); + + /* now, after calculating datasize, round up nbytes to a word multiple */ + nbytes = (nbytes + sizeof(word) - 1) & ~(sizeof(word) - 1); + + if (f == NULL) + f = &fdefault; + + AlcBlk(blk, b_external, T_External, nbytes); + blk->blksize = nbytes; + blk->id = extl_ser++; + blk->funcs = f; + if (data != NULL) + memcpy(blk->data, data, datasize); + return blk; + } + +/* * alcfile - allocate a file block in the block region. */ @@ -429,23 +365,6 @@ union block *recptr; * alcrefresh - allocate a co-expression refresh block. */ -#if COMPILER -struct b_refresh *alcrefresh(na, nl, nt, wrk_sz) -int na; -int nl; -int nt; -int wrk_sz; - { - struct b_refresh *blk; - - AlcVarBlk(blk, b_refresh, T_Refresh, na + nl) - blk->nlocals = nl; - blk->nargs = na; - blk->ntemps = nt; - blk->wrk_size = wrk_sz; - return blk; - } -#else /* COMPILER */ struct b_refresh *alcrefresh(entryx, na, nl) word *entryx; int na, nl; @@ -457,7 +376,6 @@ int na, nl; blk->numlocals = nl; return blk; } -#endif /* COMPILER */ /* * alcselem - allocate a set element block. @@ -490,16 +408,6 @@ register word slen; register char *d; char *ofree; -#ifdef MultiThread - StrLen(ts) = slen; - StrLoc(ts) = s; -#ifdef EventMon - if (!noMTevents) -#endif /* EventMon */ - EVVal(slen, E_String); - s = StrLoc(ts); -#endif /* MultiThread */ - /* * Make sure there is enough room in the string space. */ @@ -606,7 +514,6 @@ union block *bp; syserr ("deallocation botch"); rp->free = (char *)bp; blktotal -= nbytes; - EVVal(nbytes, E_BlkDeAlc); } /* @@ -691,16 +598,6 @@ word nbytes; if (curr->Gprev) curr->Gprev->Gnext = rp; curr->Gprev = rp; *pcurr = rp; -#ifdef EventMon - if (!noMTevents) { - if (region == Strings) { - EVVal(rp->size, E_TenureString); - } - else { - EVVal(rp->size, E_TenureBlock); - } - } -#endif /* EventMon */ return rp->free; } diff --git a/src/runtime/rcoexpr.r b/src/runtime/rcoexpr.r index 4036ef6..a613873 100644 --- a/src/runtime/rcoexpr.r +++ b/src/runtime/rcoexpr.r @@ -2,10 +2,6 @@ * File: rcoexpr.r -- co_init, co_chng */ -#if COMPILER -static continuation coexpr_fnc; /* function to call after switching stacks */ -#endif /* COMPILER */ - /* * co_init - use the contents of the refresh block to initialize the * co-expression. @@ -13,9 +9,6 @@ static continuation coexpr_fnc; /* function to call after switching stacks */ void co_init(sblkp) struct b_coexpr *sblkp; { -#ifndef Coexpr - syserr("co_init() called, but co-expressions not implemented"); -#else /* Coexpr */ register word *newsp; register struct b_refresh *rblkp; register dptr dp, dsp; @@ -27,60 +20,16 @@ struct b_coexpr *sblkp; * Get pointer to refresh block. */ rblkp = (struct b_refresh *)BlkLoc(sblkp->freshblk); - -#if COMPILER - na = rblkp->nargs; /* number of arguments */ - nl = rblkp->nlocals; /* number of locals */ - nt = rblkp->ntemps; /* number of temporaries */ - - /* - * The C stack must be aligned on the correct boundary. For up-growing - * stacks, the C stack starts after the initial procedure frame of - * the co-expression block. For down-growing stacks, the C stack starts - * at the last word of the co-expression block. - */ -#ifdef UpStack - frame_size = sizeof(struct p_frame) + sizeof(struct descrip) * (nl + na + - nt - 1) + rblkp->wrk_size; - stack_strt = (word)((char *)&sblkp->pf + frame_size + StackAlign*WordSize); -#else /* UpStack */ - stack_strt = (word)((char *)sblkp + stksize - WordSize); -#endif /* UpStack */ - sblkp->cstate[0] = stack_strt & ~(WordSize * StackAlign - 1); - - sblkp->es_argp = &sblkp->pf.tend.d[nl + nt]; /* args follow temporaries */ - -#else /* COMPILER */ - na = (rblkp->pfmkr).pf_nargs + 1; /* number of arguments */ nl = (int)rblkp->numlocals; /* number of locals */ /* * The interpreter stack starts at word after co-expression stack block. - * C stack starts at end of stack region on machines with down-growing C - * stacks and somewhere in the middle of the region. - * - * The C stack is aligned on a doubleword boundary. For up-growing - * stacks, the C stack starts in the middle of the stack portion - * of the static block. For down-growing stacks, the C stack starts - * at the last word of the static block. + * There is no longer C state in this region; pthreads makes another stack. */ newsp = (word *)((char *)sblkp + sizeof(struct b_coexpr)); - -#ifdef UpStack - sblkp->cstate[0] = - ((word)((char *)sblkp + (stksize - sizeof(*sblkp))/2) - &~((word)WordSize*StackAlign-1)); -#else /* UpStack */ - sblkp->cstate[0] = - ((word)((char *)sblkp + stksize - WordSize) - &~((word)WordSize*StackAlign-1)); -#endif /* UpStack */ - - sblkp->es_argp = (dptr)newsp; /* args are first thing on stack */ - -#endif /* COMPILER */ + sblkp->es_argp = (dptr)newsp; /* args are first thing on stack */ /* * Copy arguments onto new stack. @@ -93,16 +42,6 @@ struct b_coexpr *sblkp; /* * Set up state variables and initialize procedure frame. */ -#if COMPILER - sblkp->es_pfp = &sblkp->pf; - sblkp->es_tend = &sblkp->pf.tend; - sblkp->pf.old_pfp = NULL; - sblkp->pf.rslt = NULL; - sblkp->pf.succ_cont = NULL; - sblkp->pf.tend.previous = NULL; - sblkp->pf.tend.num = nl + na + nt; - sblkp->es_actstk = NULL; -#else /* COMPILER */ *((struct pf_marker *)dsp) = rblkp->pfmkr; sblkp->es_pfp = (struct pf_marker *)dsp; sblkp->es_tend = NULL; @@ -111,25 +50,14 @@ struct b_coexpr *sblkp; sblkp->es_gfp = 0; sblkp->es_efp = 0; sblkp->es_ilevel = 0; -#endif /* COMPILER */ sblkp->tvalloc = NULL; /* * Copy locals into the co-expression. */ -#if COMPILER - dsp = sblkp->pf.tend.d; -#endif /* COMPILER */ for (i = 1; i <= nl; i++) *dsp++ = *dp++; -#if COMPILER - /* - * Initialize temporary variables. - */ - for (i = 1; i <= nt; i++) - *dsp++ = nulldesc; -#else /* COMPILER */ /* * Push two null descriptors on the stack. */ @@ -137,9 +65,6 @@ struct b_coexpr *sblkp; *dsp++ = nulldesc; sblkp->es_sp = (word *)dsp - 1; -#endif /* COMPILER */ - -#endif /* Coexpr */ } /* @@ -152,60 +77,22 @@ struct descrip *rsltloc;/* location to put result */ int swtch_typ; /* A_Coact, A_Coret, A_Cofail, or A_MTEvent */ int first; { -#ifndef Coexpr - syserr("co_chng() called, but co-expressions not implemented"); -#else /* Coexpr */ register struct b_coexpr *ccp; static int coexp_act; /* used to pass signal across activations */ /* back to whomever activates, if they care */ ccp = (struct b_coexpr *)BlkLoc(k_current); -#if !COMPILER -#ifdef EventMon - switch(swtch_typ) { - /* - * A_MTEvent does not generate an event. - */ - case A_MTEvent: - break; - case A_Coact: - EVValX(ncp,E_Coact); - if (!is:null(curpstate->eventmask)) { - curpstate->parent->eventsource.dword = D_Coexpr; - BlkLoc(curpstate->parent->eventsource) = (union block *)ncp; - } - break; - case A_Coret: - EVValX(ncp,E_Coret); - if (!is:null(curpstate->eventmask)) { - curpstate->parent->eventsource.dword = D_Coexpr; - BlkLoc(curpstate->parent->eventsource) = (union block *)ncp; - } - break; - case A_Cofail: - EVValX(ncp,E_Cofail); - if (!is:null(curpstate->eventmask) && ncp->program == curpstate) { - curpstate->parent->eventsource.dword = D_Coexpr; - BlkLoc(curpstate->parent->eventsource) = (union block *)ncp; - } - break; - } -#endif /* EventMon */ -#endif /* COMPILER */ - /* * Determine if we need to transmit a value. */ if (valloc != NULL) { -#if !COMPILER /* * Determine if we need to dereference the transmitted value. */ if (Var(*valloc)) retderef(valloc, (word *)glbl_argp, sp); -#endif /* COMPILER */ if (ncp->tvalloc != NULL) *ncp->tvalloc = *valloc; @@ -220,31 +107,14 @@ int first; ccp->es_argp = glbl_argp; ccp->es_tend = tend; -#if !COMPILER ccp->es_efp = efp; ccp->es_gfp = gfp; ccp->es_ipc = ipc; ccp->es_sp = sp; ccp->es_ilevel = ilevel; -#endif /* COMPILER */ - -#if COMPILER - if (line_info) { - ccp->file_name = file_name; - ccp->line_num = line_num; - file_name = ncp->file_name; - line_num = ncp->line_num; - } -#endif /* COMPILER */ -#if COMPILER - if (debug_info) -#endif /* COMPILER */ - if (k_trace) -#ifdef EventMon - if (swtch_typ != A_MTEvent) -#endif /* EventMon */ - cotrace(ccp, ncp, swtch_typ, valloc); + if (k_trace) + cotrace(ccp, ncp, swtch_typ, valloc); /* * Establish state for new co-expression. @@ -252,45 +122,20 @@ int first; pfp = ncp->es_pfp; tend = ncp->es_tend; -#if !COMPILER efp = ncp->es_efp; gfp = ncp->es_gfp; ipc = ncp->es_ipc; sp = ncp->es_sp; ilevel = (int)ncp->es_ilevel; -#endif /* COMPILER */ - -#if !COMPILER -#ifdef MultiThread - /* - * Enter the program state of the co-expression being activated - */ - ENTERPSTATE(ncp->program); -#endif /* MultiThread */ -#endif /* COMPILER */ glbl_argp = ncp->es_argp; BlkLoc(k_current) = (union block *)ncp; -#if COMPILER - coexpr_fnc = ncp->fnc; -#endif /* COMPILER */ - -#ifdef EventMon - /* - * From here on out, A_MTEvent looks like a A_Coact. - */ - if (swtch_typ == A_MTEvent) - swtch_typ = A_Coact; -#endif /* EventMon */ - coexp_act = swtch_typ; coswitch(ccp->cstate, ncp->cstate,first); return coexp_act; -#endif /* Coexpr */ } -#ifdef Coexpr /* * new_context - determine what function to call to execute the new * co-expression; this completes the context switch. @@ -299,17 +144,5 @@ void new_context(fsig,cargp) int fsig; dptr cargp; { -#if COMPILER - (*coexpr_fnc)(); -#else /* COMPILER */ interp(fsig, cargp); -#endif /* COMPILER */ - } -#else /* Coexpr */ -/* dummy new_context if co-expressions aren't supported */ -void new_context(fsig,cargp) -int fsig; -dptr cargp; - { } -#endif /* Coexpr */ diff --git a/src/runtime/rcomp.r b/src/runtime/rcomp.r index 6cd0610..2ad3e35 100644 --- a/src/runtime/rcomp.r +++ b/src/runtime/rcomp.r @@ -35,8 +35,6 @@ dptr dp1, dp2; switch (Type(*dp1)) { -#ifdef LargeInts - case T_Integer: if (Type(*dp2) != T_Lrgint) { v1 = IntVal(*dp1); @@ -56,20 +54,6 @@ dptr dp1, dp2; return Equal; return ((lresult > 0) ? Greater : Less); -#else /* LargeInts */ - - case T_Integer: - v1 = IntVal(*dp1); - v2 = IntVal(*dp2); - if (v1 < v2) - return Less; - else if (v1 == v2) - return Equal; - else - return Greater; - -#endif /* LargeInts */ - case T_Coexpr: /* * Collate on co-expression id. @@ -171,14 +155,15 @@ dptr dp1, dp2; return ((lresult > 0) ? Greater : Less); case T_External: - /* - * Collate these values according to the relative positions of - * their blocks in the heap. - */ - lresult = ((long)BlkLoc(*dp1) - (long)BlkLoc(*dp2)); - if (lresult == 0) - return Equal; - return ((lresult > 0) ? Greater : Less); + /* + * Call associated collation function. + */ + { + struct descrip result = callextfunc(&extlcmp, dp1, dp2); + long ans = result.vword.integr; + if (ans == 0) return Equal; + return ans > 0 ? Greater : Less; + } default: syserr("anycmp: unknown datatype."); @@ -201,17 +186,12 @@ dptr dp; return 0; case T_Integer: return 1; - -#ifdef LargeInts case T_Lrgint: return 1; -#endif /* LargeInts */ - case T_Real: return 2; - - /* string: return 3 (see above) */ - + /* String (handled above): /* + /* return 3; */ case T_Cset: return 4; case T_File: @@ -285,12 +265,9 @@ dptr dp1, dp2; result = (IntVal(*dp1) == IntVal(*dp2)); break; -#ifdef LargeInts case T_Lrgint: result = (bigcmp(dp1, dp2) == 0); break; -#endif /* LargeInts */ - case T_Real: GetReal(dp1, rres1); diff --git a/src/runtime/rdebug.r b/src/runtime/rdebug.r index 26d1167..589ebeb 100644 --- a/src/runtime/rdebug.r +++ b/src/runtime/rdebug.r @@ -18,28 +18,6 @@ static void xtrace * tracebk - print a trace of procedure calls. */ -#if COMPILER - -void tracebk(lcl_pfp, argp) -struct p_frame *lcl_pfp; -dptr argp; - { - struct b_proc *cproc; - - struct debug *debug; - word nparam; - - if (lcl_pfp == NULL) - return; - debug = PFDebug(*lcl_pfp); - tracebk(lcl_pfp->old_pfp, lcl_pfp->old_argp); - cproc = debug->proc; - xtrace(cproc, (word)abs((int)cproc->nparam), argp, debug->old_line, - debug->old_fname); - } - -#else /* COMPILER */ - void tracebk(lcl_pfp, argp) struct pf_marker *lcl_pfp; dptr argp; @@ -87,8 +65,6 @@ dptr argp; pfp = (struct pf_marker *)(pfp->pf_efp); } } - -#endif /* COMPILER */ /* * xtrace - procedure *bp is being called with nargs arguments, the first @@ -105,16 +81,11 @@ char *pfile; if (bp == NULL) fprintf(stderr, "????"); else { - -#if COMPILER - putstr(stderr, &(bp->pname)); -#else /* COMPILER */ if (arg[0].dword == D_Proc) putstr(stderr, &(bp->pname)); else outimage(stderr, arg, 0); arg++; -#endif /* COMPILER */ putc('(', stderr); while (nargs--) { @@ -147,15 +118,9 @@ int get_name(dp1,dp0) word i, j, k; int t; -#if COMPILER - arg1 = glbl_argp; - loc1 = pfp->tend.d; - proc = PFDebug(*pfp)->proc; -#else /* COMPILER */ arg1 = &glbl_argp[1]; loc1 = pfp->pf_locals; proc = &BlkLoc(*glbl_argp)->proc; -#endif /* COMPILER */ type_case *dp1 of { tvsubs: { @@ -196,14 +161,6 @@ int get_name(dp1,dp0) StrLen(*dp0) = 6; StrLoc(*dp0) = "&trace"; } - -#ifdef FncTrace - else if (VarLoc(*dp1) == &kywd_ftrc) { - StrLen(*dp0) = 7; - StrLoc(*dp0) = "&ftrace"; - } -#endif /* FncTrace */ - else if (VarLoc(*dp1) == &kywd_dmp) { StrLen(*dp0) = 5; StrLoc(*dp0) = "&dump"; @@ -216,21 +173,6 @@ int get_name(dp1,dp0) syserr("name: unknown integer keyword variable"); kywdevent: -#ifdef MultiThread - if (VarLoc(*dp1) == &curpstate->eventsource) { - StrLen(*dp0) = 12; - StrLoc(*dp0) = "&eventsource"; - } - else if (VarLoc(*dp1) == &curpstate->eventval) { - StrLen(*dp0) = 11; - StrLoc(*dp0) = "&eventvalue"; - } - else if (VarLoc(*dp1) == &curpstate->eventcode) { - StrLen(*dp0) = 10; - StrLoc(*dp0) = "&eventcode"; - } - else -#endif /* MultiThread */ syserr("name: unknown event keyword variable"); kywdwin: { @@ -293,20 +235,11 @@ int get_name(dp1,dp0) i = varptr - &blkptr->lelem.lslots[blkptr->lelem.first] + 1; if (i < 1) i += blkptr->lelem.nslots; -#ifdef ListFix - while (BlkType(blkptr->lelem.listprev) == T_Lelem) { -#else /* ListFix */ while (blkptr->lelem.listprev != NULL) { -#endif /* ListFix */ blkptr = blkptr->lelem.listprev; i += blkptr->lelem.nused; } -#ifdef ListFix - sprintf(sbuf,"list_%d[%ld]", - (long)blkptr->lelem.listprev->list.id, (long)i); -#else /* ListFix */ sprintf(sbuf,"L[%ld]", (long)i); -#endif /* ListFix */ i = strlen(sbuf); Protect(StrLoc(*dp0) = alcstr(sbuf,i), return Error); StrLen(*dp0) = i; @@ -314,16 +247,8 @@ int get_name(dp1,dp0) case T_Record: /* record */ i = varptr - blkptr->record.fields; proc = &blkptr->record.recdesc->proc; - -#ifdef TableFix - sprintf(sbuf,"record %s_%d.%s", StrLoc(proc->recname), - blkptr->record.id, - StrLoc(proc->lnames[i])); -#else sprintf(sbuf,"%s.%s", StrLoc(proc->recname), StrLoc(proc->lnames[i])); -#endif - i = strlen(sbuf); Protect(StrLoc(*dp0) = alcstr(sbuf,i), return Error); StrLen(*dp0) = i; @@ -334,104 +259,13 @@ int get_name(dp1,dp0) return Error; break; default: /* none of the above */ -#ifdef EventMon - *dp0 = emptystr; -#else /* EventMon */ syserr("name: invalid structure reference"); -#endif /* EventMon */ - } } } return Succeeded; } -#if COMPILER -#begdef PTraceSetup() - struct b_proc *proc; - - --k_trace; - showline(file_name, line_num); - showlevel(k_level); - proc = PFDebug(*pfp)->proc; /* get address of procedure block */ - putstr(stderr, &proc->pname); -#enddef - -/* - * ctrace - a procedure is being called; produce a trace message. - */ -void ctrace() - { - dptr arg; - int n; - - PTraceSetup(); - - putc('(', stderr); - arg = glbl_argp; - n = abs((int)proc->nparam); - while (n--) { - outimage(stderr, arg++, 0); - if (n) - putc(',', stderr); - } - putc(')', stderr); - putc('\n', stderr); - fflush(stderr); - } - -/* - * rtrace - a procedure is returning; produce a trace message. - */ - -void rtrace() - { - PTraceSetup(); - - fprintf(stderr, " returned "); - outimage(stderr, pfp->rslt, 0); - putc('\n', stderr); - fflush(stderr); - } - -/* - * failtrace - procedure named s is failing; produce a trace message. - */ - -void failtrace() - { - PTraceSetup(); - - fprintf(stderr, " failed\n"); - fflush(stderr); - } - -/* - * strace - a procedure is suspending; produce a trace message. - */ - -void strace() - { - PTraceSetup(); - - fprintf(stderr, " suspended "); - outimage(stderr, pfp->rslt, 0); - putc('\n', stderr); - fflush(stderr); - } - -/* - * atrace - a procedure is being resumed; produce a trace message. - */ -void atrace() - { - PTraceSetup(); - - fprintf(stderr, " resumed\n"); - fflush(stderr); - } -#endif /* COMPILER */ - /* * keyref(bp,dp) -- print name of subscripted table */ @@ -451,16 +285,7 @@ static int keyref(bp, dp) */ s2 = StrLoc(*dp); len = StrLen(*dp); -#ifdef TableFix - if (BlkType(bp) == T_Tvtbl) - bp = bp->tvtbl.clink; - else - while(BlkType(bp) == T_Telem) - bp = bp->telem.clink; - sprintf(sbuf, "table_%d[", bp->table.id); -#else /* TableFix */ strcpy(sbuf, "T["); -#endif /* TableFix */ { char * dest = sbuf + strlen(sbuf); strncpy(dest, s2, len); dest[len] = '\0'; @@ -473,7 +298,6 @@ static int keyref(bp, dp) return Succeeded; } -#ifdef Coexpr /* * cotrace -- a co-expression context switch; produce a trace message. */ @@ -484,26 +308,16 @@ int swtch_typ; dptr valloc; { struct b_proc *proc; - -#if !COMPILER inst t_ipc; -#endif /* !COMPILER */ --k_trace; -#if COMPILER - showline(ccp->file_name, ccp->line_num); - proc = PFDebug(*ccp->es_pfp)->proc; /* get address of procedure block */ -#else /* COMPILER */ - /* * Compute the ipc of the instruction causing the context switch. */ t_ipc.op = ipc.op - 1; showline(findfile(t_ipc.opnd), findline(t_ipc.opnd)); proc = (struct b_proc *)BlkLoc(*glbl_argp); -#endif /* COMPILER */ - showlevel(k_level); putstr(stderr, &proc->pname); fprintf(stderr,"; co-expression_%ld ", (long)ccp->id); @@ -525,7 +339,6 @@ dptr valloc; fprintf(stderr,"co-expression_%ld\n", (long)ncp->id); fflush(stderr); } -#endif /* Coexpr */ /* * showline - print file and line number information. @@ -559,11 +372,8 @@ register int n; } } -#if !COMPILER - #include "../h/opdefs.h" - extern struct descrip value_tmp; /* argument of Op_Apply */ extern struct b_proc *opblks[]; @@ -812,7 +622,6 @@ dptr dp; fflush(stderr); } -#ifdef Coexpr /* * coacttrace -- co-expression is being activated; produce a trace message. */ @@ -883,8 +692,6 @@ struct b_coexpr *ncp; (long)ccp->id, (long)ncp->id); fflush(stderr); } -#endif /* Coexpr */ -#endif /* !COMPILER */ /* * Service routine to display variables in given number of @@ -892,11 +699,7 @@ struct b_coexpr *ncp; */ int xdisp(fp,dp,count,f) -#if COMPILER - struct p_frame *fp; -#else /* COMPILER */ struct pf_marker *fp; -#endif /* COMPILER */ register dptr dp; int count; FILE *f; @@ -909,13 +712,7 @@ int xdisp(fp,dp,count,f) while (count--) { /* go back through 'count' frames */ if (fp == NULL) break; /* needed because &level is wrong in co-expressions */ - -#if COMPILER - bp = PFDebug(*fp)->proc; /* get address of procedure block */ -#else /* COMPILER */ bp = (struct b_proc *)BlkLoc(*dp++); /* get addr of procedure block */ - /* #%#% was: no post-increment there, but *pre*increment dp below */ -#endif /* COMPILER */ /* * Print procedure name. @@ -939,11 +736,7 @@ int xdisp(fp,dp,count,f) /* * Print locals. */ -#if COMPILER - dp = fp->tend.d; -#else /* COMPILER */ dp = &fp->pf_locals[0]; -#endif /* COMPILER */ for (n = bp->ndynam; n > 0; n--) { fprintf(f, " "); putstr(f, np); @@ -965,26 +758,14 @@ int xdisp(fp,dp,count,f) putc('\n', f); np++; } - -#if COMPILER - dp = fp->old_argp; - fp = fp->old_pfp; -#else /* COMPILER */ dp = fp->pf_argp; fp = fp->pf_pfp; -#endif /* COMPILER */ } /* * Print globals. Sort names in lexical order using temporary index array. */ - -#if COMPILER - nglobals = n_globals; -#else /* COMPILER */ nglobals = eglobals - globals; -#endif /* COMPILER */ - indices = (word *)malloc(nglobals * sizeof(word)); if (indices == NULL) return Failed; diff --git a/src/runtime/rexternal.r b/src/runtime/rexternal.r new file mode 100644 index 0000000..c3a33c6 --- /dev/null +++ b/src/runtime/rexternal.r @@ -0,0 +1,136 @@ +/* + * File: rexternal.r + * Functions dealing with external values and their custom functions. + * + * Functions in this file that declare (argc, argv) signatures + * follow the ipl/cfuncs/icall.h calling conventions and call + * dynamically loaded C functions if available for this external type. + */ + +/* + * callextfunc(func, d1, d2) -- call func(argc, argv) via icall.h conventions. + * + * func() is called with argv=1 if d2 is null or argv=2 if not. + */ +struct descrip callextfunc(int (*func)(int, dptr), dptr dp1, dptr dp2) { + struct descrip stack[3]; + int nargs = 1; + + stack[0] = nulldesc; + stack[1] = *dp1; + if (dp2 != NULL) { + stack[2] = *dp2; + nargs = 2; + } + if (func(nargs, stack) != 0) + syserr("external value helper function did not succeed"); + return stack[0]; + } + +/* + * extlname(argc, argv) - return the name of the type of external value argv[1]. + */ +int extlname(int argc, dptr argv) + { + struct b_external *block = (struct b_external *)BlkLoc(argv[1]); + struct b_extlfuns *funcs = block->funcs; + + if (funcs->extlname != NULL) { + funcs->extlname(1, argv); /* call custom name function */ + if (! is:string(argv[0])) + syserr("extlname: not a string"); + } + else { + argv[0].dword = 8; /* strlen("external") */ + argv[0].vword.sptr = "external"; + } + return 0; + } + +/* + * extlimage(argc, argv) - return the image of external value argv[1]. + * + * Always sets argv[0] to a valid string, but returns Error + * if storage is not available for formatting the details. + */ +int extlimage(int argc, dptr argv) + { + struct b_external *block = (struct b_external *)BlkLoc(argv[1]); + struct b_extlfuns *funcs = block->funcs; + word len; + int nwords; + + if (funcs->extlimage != NULL) { + funcs->extlimage(1, argv); /* call custom image function */ + if (! is:string(argv[0])) + syserr("extlimage: not a string"); + return 0; + } + + extlname(1, &argv[0]); /* get type name, result in argv[0] */ + len = StrLen(argv[0]); + Protect(reserve(Strings, len + 30), return Error); + Protect(StrLoc(argv[0]) = alcstr(StrLoc(argv[0]), len), return Error); + /* + * to type name append "_<id>(nwords)" + */ + nwords = ((char*)block + block->blksize - (char*)block->data) / sizeof(word); + len += sprintf(StrLoc(argv[0]) + len, "_%ld(%d)", (long)block->id, nwords); + StrLen(argv[0]) = len; + return 0; + } + +/* + * extlcmp(argc, argv) - compare two external values argv[1] and argv[2]. + */ + +int extlcmp(int argc, dptr argv) { + struct b_external *block1 = (struct b_external *)BlkLoc(argv[1]); + struct b_external *block2 = (struct b_external *)BlkLoc(argv[2]); + struct b_extlfuns *funcs = block1->funcs; + + /* + * If the two values share the same function list, then by definition + * they are the same type and are compared using a custom function if + * one is provided in the list. + */ + if (block1->funcs == block2->funcs && funcs->extlcmp != NULL) { + funcs->extlcmp(1, argv); /* call custom comparison function */ + if (! is:integer(argv[0])) + syserr("extlcmp: not an integer"); + } + else { + /* + * Otherwise, sort by name and then by serial number. + */ + struct descrip name1 = callextfunc(&extlname, &argv[1], NULL); + struct descrip name2 = callextfunc(&extlname, &argv[2], NULL); + long result = lexcmp(&name1, &name2); + if (result == Equal) + result = block1->id - block2->id; + argv[0].dword = D_Integer; + argv[0].vword.integr = result; + } + return 0; + } + +/* + * extlcopy(argc, argv) - return a copy of external value argv[1]. + * + * By default this is the original descriptor. + */ + +int extlcopy(int argc, dptr argv) { + struct b_external *block = (struct b_external *)BlkLoc(argv[1]); + struct b_extlfuns *funcs = block->funcs; + + if (funcs->extlcopy != NULL) { + funcs->extlcopy(1, argv); /* call custom copy function */ + if (Qual(argv[0]) || Type(argv[0]) != T_External) + syserr("extlcopy: not an external"); + } + else { + argv[0] = argv[1]; /* the identical external value */ + } + return 0; + } diff --git a/src/runtime/rlrgint.r b/src/runtime/rlrgint.r index f624cc7..ec1aaa4 100644 --- a/src/runtime/rlrgint.r +++ b/src/runtime/rlrgint.r @@ -3,8 +3,6 @@ * Large integer arithmetic */ -#ifdef LargeInts - extern int over_flow; /* @@ -2298,5 +2296,3 @@ word n; return 0; return u[n - 1] > (DIGIT)k ? 1 : -1; } - -#endif /* LargeInts */ diff --git a/src/runtime/rmemmgt.r b/src/runtime/rmemmgt.r index 4a9daa2..8cc6956 100644 --- a/src/runtime/rmemmgt.r +++ b/src/runtime/rmemmgt.r @@ -20,20 +20,13 @@ static void adjust (char *source, char *dest); static void compact (char *source); static void mvc (uword n, char *src, char *dest); -#ifdef MultiThread -static void markprogram (struct progstate *pstate); -#endif /*MultiThread*/ - /* * Variables */ - -#ifndef MultiThread word coll_stat = 0; /* collections in static region */ word coll_str = 0; /* collections in string region */ word coll_blk = 0; /* collections in block region */ word coll_tot = 0; /* total collections */ -#endif /* MultiThread */ word alcnum = 0; /* co-expressions allocated since g.c. */ dptr *quallist; /* string qualifier list */ @@ -89,13 +82,7 @@ int firstd[] = { 0, /* T_Real (3), real number */ 0, /* T_Cset (4), cset */ 3*WordSize, /* T_File (5), file block */ - -#ifdef MultiThread - 8*WordSize, /* T_Proc (6), procedure block */ -#else /* MultiThread */ 7*WordSize, /* T_Proc (6), procedure block */ -#endif /* MultiThread */ - 4*WordSize, /* T_Record (7), record block */ 0, /* T_List (8), list header block */ 7*WordSize, /* T_Lelem (9), list element block */ @@ -106,13 +93,7 @@ int firstd[] = { 3*WordSize, /* T_Tvtbl (14), table element trapped variable */ 0, /* T_Slots (15), set/table hash block */ 3*WordSize, /* T_Tvsubs (16), substring trapped variable */ - -#if COMPILER - 2*WordSize, /* T_Refresh (17), refresh block */ -#else /* COMPILER */ (4+Wsizeof(struct pf_marker))*WordSize, /* T_Refresh (17), refresh block */ -#endif /* COMPILER */ - -1, /* T_Coexpr (18), co-expression block */ 0, /* T_External (19), external block */ -1, /* T_Kywdint (20), integer keyword variable */ @@ -252,35 +233,18 @@ uword segsize[] = { * initalloc - initialization routine to allocate memory regions */ -#if COMPILER -void initalloc() - { - -#else /* COMPILER */ -#ifdef MultiThread -void initalloc(codesize,p) -struct progstate *p; -#else /* MultiThread */ void initalloc(codesize) -#endif /* MultiThread */ word codesize; { -#ifdef MultiThread - struct region *ps, *pb; -#endif if ((uword)codesize > (unsigned)MaxBlock) error(NULL, "icode file too large"); /* * Allocate icode region */ -#ifdef MultiThread - if (codesize) -#endif /* MultiThread */ if ((code = (char *)AllocReg(codesize)) == NULL) error(NULL, "insufficient memory, corrupted icode file, or wrong platform"); -#endif /* COMPILER */ /* * Set up allocated memory. The regions are: @@ -290,25 +254,6 @@ word codesize; * Qualifier list */ -#ifdef MultiThread - ps = p->stringregion; - ps->free = ps->base = (char *)AllocReg(ps->size); - if (ps->free == NULL) - error(NULL, "insufficient memory for string region"); - ps->end = ps->base + ps->size; - - pb = p->blockregion; - pb->free = pb->base = (char *)AllocReg(pb->size); - if (pb->free == NULL) - error(NULL, "insufficient memory for block region"); - pb->end = pb->base + pb->size; - - if (p == &rootpstate) { - if ((quallist = (dptr *)malloc(qualsize)) == NULL) - error(NULL, "insufficient memory for qualifier list"); - equallist = (dptr *)((char *)quallist + qualsize); - } -#else /* MultiThread */ { uword t1, t2; t1 = ssize; @@ -331,7 +276,6 @@ word codesize; if ((quallist = (dptr *)malloc(qualsize)) == NULL) error(NULL, "insufficient memory for qualifier list"); equallist = (dptr *)((char *)quallist + qualsize); -#endif /* MultiThread */ } /* @@ -343,11 +287,6 @@ int region; { struct b_coexpr *cp; -#ifdef EventMon - if (!noMTevents) - EVVal((word)region,E_Collect); -#endif /* EventMon */ - switch (region) { case Static: coll_stat++; @@ -366,11 +305,8 @@ int region; /* * Garbage collection cannot be done until initialization is complete. */ - -#if !COMPILER if (sp == NULL) return 0; -#endif /* !COMPILER */ /* * Sync the values (used by sweep) in the coexpr block for ¤t @@ -378,13 +314,10 @@ int region; */ cp = (struct b_coexpr *)BlkLoc(k_current); cp->es_tend = tend; - -#if !COMPILER cp->es_pfp = pfp; cp->es_gfp = gfp; cp->es_efp = efp; cp->es_sp = sp; -#endif /* !COMPILER */ /* * Reset qualifier list. @@ -395,18 +328,13 @@ int region; /* * Mark the stacks for &main and the current co-expression. */ -#ifdef MultiThread - markprogram(&rootpstate); -#endif /* MultiThread */ markblock(&k_main); markblock(&k_current); /* * Mark &subject and the cached s2 and s3 strings for map. */ -#ifndef MultiThread postqual(&k_subject); postqual(&kywd_prog); -#endif /* MultiThread */ if (Qual(maps2)) /* caution: the cached arguments of */ postqual(&maps2); /* map may not be strings. */ else if (Pointer(maps2)) @@ -436,7 +364,6 @@ int region; * Mark the globals and the statics. */ -#ifndef MultiThread { register struct descrip *dp; for (dp = globals; dp < eglobals; dp++) if (Qual(*dp)) @@ -457,7 +384,6 @@ int region; if (is:file(lastEventWin)) markblock(&(lastEventWin)); #endif /* Graphics */ -#endif /* MultiThread */ reclaim(); @@ -483,75 +409,10 @@ int region; } } -#ifdef EventMon - if (!noMTevents) { - mmrefresh(); - EVValD(&nulldesc, E_EndCollect); - } -#endif /* EventMon */ - return 1; } /* - * markprogram - traverse pointers out of a program state structure - */ - -#ifdef MultiThread -#define PostDescrip(d) \ - if (Qual(d)) \ - postqual(&(d)); \ - else if (Pointer(d))\ - markblock(&(d)); - -static void markprogram(pstate) -struct progstate *pstate; - { - struct descrip *dp; - - PostDescrip(pstate->parentdesc); - PostDescrip(pstate->eventmask); - PostDescrip(pstate->opcodemask); - PostDescrip(pstate->eventcode); - PostDescrip(pstate->eventval); - PostDescrip(pstate->eventsource); - - /* Kywd_err, &error, always an integer */ - /* Kywd_pos, &pos, always an integer */ - postqual(&(pstate->ksub)); - postqual(&(pstate->Kywd_prog)); - /* Kywd_ran, &random, always an integer */ - /* Kywd_trc, &trace, always an integer */ - - /* - * Mark the globals and the statics. - */ - for (dp = pstate->Globals; dp < pstate->Eglobals; dp++) - if (Qual(*dp)) - postqual(dp); - else if (Pointer(*dp)) - markblock(dp); - - for (dp = pstate->Statics; dp < pstate->Estatics; dp++) - if (Qual(*dp)) - postqual(dp); - else if (Pointer(*dp)) - markblock(dp); - - /* - * no marking for &x, &y, &row, &col, &interval, all integers - */ -#ifdef Graphics - PostDescrip(pstate->LastEventWin); /* last Event() win */ - PostDescrip(pstate->Kywd_xwin[XKey_Window]); /* &window */ -#endif /* Graphics */ - - PostDescrip(pstate->K_errorvalue); - PostDescrip(pstate->T_errorvalue); - } -#endif /* MultiThread */ - -/* * postqual - mark a string qualifier. Strings outside the string space * are ignored. */ @@ -693,17 +554,6 @@ dptr dp; BlkType(block) = (uword)dp; sweep((struct b_coexpr *)block); -#ifdef MultiThread - if (((struct b_coexpr *)block)+1 == - (struct b_coexpr *)((struct b_coexpr *)block)->program){ - /* - * This coexpr is an &main; traverse its roots - */ - markprogram(((struct b_coexpr *)block)->program); - } -#endif /* MultiThread */ - -#ifdef Coexpr /* * Mark the activators of this co-expression. The activators are * stored as a list of addresses, but markblock requires the address @@ -723,7 +573,6 @@ dptr dp; } if(BlkLoc(cp->freshblk) != NULL) markblock(&((struct b_coexpr *)block)->freshblk); -#endif /* Coexpr */ } else { @@ -950,12 +799,9 @@ struct b_coexpr *ce; } } } -#if !COMPILER sweep_stk(ce); -#endif /* !COMPILER */ } -#if !COMPILER /* * sweep_stk - sweep the stack, marking all descriptors there. Method * is to start at a known point, specifically, the frame that the @@ -992,19 +838,6 @@ struct b_coexpr *ce; s_sp = ce->es_sp; nargs = 0; /* Nargs counter is 0 initially. */ -#ifdef MultiThread - if (fp == 0) { - if (is:list(* (dptr) (s_sp - 1))) { - /* - * this is the argument list of an un-started task - */ - if (Pointer(*((dptr)(&s_sp[-1])))) { - markblock((dptr)&s_sp[-1]); - } - } - } -#endif /* MultiThread */ - while ((fp != 0 || nargs)) { /* Keep going until current fp is 0 and no arguments are left. */ if (s_sp == (word *)fp + Vwsizeof(*pfp) - 1) { @@ -1071,7 +904,6 @@ struct b_coexpr *ce; } } } -#endif /* !COMPILER */ /* * reclaim - reclaim space in the allocated memory regions. The marking @@ -1118,11 +950,7 @@ static void cofree() * Reset the type for &main. */ -#ifdef MultiThread - rootpstate.Mainhead->title = T_Coexpr; -#else /* MultiThread */ BlkLoc(k_main)->coexpr.title = T_Coexpr; -#endif /* MultiThread */ /* * The co-expression blocks are linked together through their @@ -1145,9 +973,7 @@ static void cofree() abp = abp->astk_nxt; free((pointer)xabp); } - #ifdef CoClean - coclean(xep->cstate); - #endif /* CoClean */ + coclean(xep->cstate); free((pointer)xep); } else { @@ -1392,68 +1218,3 @@ register char *src, *dest; * Note that src == dest implies no action */ } - -#ifdef DeBugIconx -/* - * descr - dump a descriptor. Used only for debugging. - */ - -void descr(dp) -dptr dp; - { - int i; - - fprintf(stderr,"%08lx: ",(long)dp); - if (Qual(*dp)) - fprintf(stderr,"%15s","qualifier"); - - else if (Var(*dp)) - fprintf(stderr,"%15s","variable"); - else { - i = Type(*dp); - switch (i) { - case T_Null: - fprintf(stderr,"%15s","null"); - break; - case T_Integer: - fprintf(stderr,"%15s","integer"); - break; - default: - fprintf(stderr,"%15s",blkname[i]); - } - } - fprintf(stderr," %08lx %08lx\n",(long)dp->dword,(long)IntVal(*dp)); - } - -/* - * blkdump - dump the allocated block region. Used only for debugging. - * NOTE: Not adapted for multiple regions. - */ - -void blkdump() - { - register char *blk; - register word type, size, fdesc; - register dptr ndesc; - - fprintf(stderr, - "\nDump of allocated block region. base:%08lx free:%08lx max:%08lx\n", - (long)blkbase,(long)blkfree,(long)blkend); - fprintf(stderr," loc type size contents\n"); - - for (blk = blkbase; blk < blkfree; blk += BlkSize(blk)) { - type = BlkType(blk); - size = BlkSize(blk); - fprintf(stderr," %08lx %15s %4ld\n",(long)blk,blkname[type], - (long)size); - if ((fdesc = firstd[type]) > 0) - for (ndesc = (dptr)(blk + fdesc); - ndesc < (dptr)(blk + size); ndesc++) { - fprintf(stderr," "); - descr(ndesc); - } - fprintf(stderr,"\n"); - } - fprintf(stderr,"end of block region.\n"); - } -#endif /* DeBugIconx */ diff --git a/src/runtime/rmisc.r b/src/runtime/rmisc.r index a302da2..18097c5 100644 --- a/src/runtime/rmisc.r +++ b/src/runtime/rmisc.r @@ -50,17 +50,7 @@ int getvar(s,vp) register dptr np; register int i; struct b_proc *bp; -#if COMPILER - struct descrip sdp; - - if (!debug_info) - fatalerr(402,NULL); - - StrLoc(sdp) = s; - StrLen(sdp) = strlen(s); -#else /* COMPILER */ struct pf_marker *fp = pfp; -#endif /* COMPILER */ /* * Is it a keyword that's a variable? @@ -97,15 +87,6 @@ int getvar(s,vp) VarLoc(*vp) = &kywd_trc; return Succeeded; } - -#ifdef FncTrace - else if (strcmp(s,"&ftrace") == 0) { - vp->dword = D_Kywdint; - VarLoc(*vp) = &kywd_ftrc; - return Succeeded; - } -#endif /* FncTrace */ - else if (strcmp(s,"&dump") == 0) { vp->dword = D_Kywdint; VarLoc(*vp) = &kywd_dmp; @@ -119,24 +100,6 @@ int getvar(s,vp) } #endif /* Graphics */ -#ifdef MultiThread - else if (strcmp(s,"&eventvalue") == 0) { - vp->dword = D_Var; - VarLoc(*vp) = (dptr)&(curpstate->eventval); - return Succeeded; - } - else if (strcmp(s,"&eventsource") == 0) { - vp->dword = D_Var; - VarLoc(*vp) = (dptr)&(curpstate->eventsource); - return Succeeded; - } - else if (strcmp(s,"&eventcode") == 0) { - vp->dword = D_Var; - VarLoc(*vp) = (dptr)&(curpstate->eventcode); - return Succeeded; - } -#endif /* MultiThread */ - else return Failed; } @@ -149,53 +112,31 @@ int getvar(s,vp) * If no such variable exits, it fails. */ -#if !COMPILER /* * If no procedure has been called (as can happen with icon_call(), * dont' try to find local identifier. */ if (pfp == NULL) goto glbvars; -#endif /* !COMPILER */ dp = glbl_argp; -#if COMPILER - bp = PFDebug(*pfp)->proc; /* get address of procedure block */ -#else /* COMPILER */ bp = (struct b_proc *)BlkLoc(*dp); /* get address of procedure block */ -#endif /* COMPILER */ np = bp->lnames; /* Check the formal parameter names. */ for (i = abs((int)bp->nparam); i > 0; i--) { -#if COMPILER - if (eq(&sdp, np) == 1) { -#else /* COMPILER */ dp++; if (strcmp(s,StrLoc(*np)) == 0) { -#endif /* COMPILER */ vp->dword = D_Var; VarLoc(*vp) = (dptr)dp; return ParamName; } np++; -#if COMPILER - dp++; -#endif /* COMPILER */ } - -#if COMPILER - dp = &pfp->tend.d[0]; -#else /* COMPILER */ dp = &fp->pf_locals[0]; -#endif /* COMPILER */ for (i = (int)bp->ndynam; i > 0; i--) { /* Check the local dynamic names. */ -#if COMPILER - if (eq(&sdp, np)) { -#else /* COMPILER */ if (strcmp(s,StrLoc(*np)) == 0) { -#endif /* COMPILER */ vp->dword = D_Var; VarLoc(*vp) = (dptr)dp; return LocalName; @@ -206,11 +147,7 @@ int getvar(s,vp) dp = &statics[bp->fstatic]; /* Check the local static names. */ for (i = (int)bp->nstatic; i > 0; i--) { -#if COMPILER - if (eq(&sdp, np)) { -#else /* COMPILER */ if (strcmp(s,StrLoc(*np)) == 0) { -#endif /* COMPILER */ vp->dword = D_Var; VarLoc(*vp) = (dptr)dp; return StaticName; @@ -219,15 +156,6 @@ int getvar(s,vp) dp++; } -#if COMPILER - for (i = 0; i < n_globals; ++i) { - if (eq(&sdp, &gnames[i])) { - vp->dword = D_Var; - VarLoc(*vp) = (dptr)&globals[i]; - return GlobalName; - } - } -#else /* COMPILER */ glbvars: dp = globals; /* Check the global variable names. */ np = gnames; @@ -240,7 +168,6 @@ glbvars: np++; dp++; } -#endif /* COMPILER */ return Failed; } @@ -288,7 +215,6 @@ dptr dp; i = (13255 * (uword)IntVal(*dp)) >> 10; break; -#ifdef LargeInts /* * The hash value of a bignum is based on its length and its * most and least significant digits. @@ -301,7 +227,6 @@ dptr dp; (b->digits[b->msd] << 8) ^ b->digits[b->lsd]; } break; -#endif /* LargeInts */ /* * The hash value of a real number is itself times a constant, @@ -412,15 +337,10 @@ int noimage; fprintf(f, "&null"); integer: - -#ifdef LargeInts if (Type(*dp) == T_Lrgint) bigprint(f, dp); else fprintf(f, "%ld", (long)IntVal(*dp)); -#else /* LargeInts */ - fprintf(f, "%ld", (long)IntVal(*dp)); -#endif /* LargeInts */ real: { char s[30]; @@ -436,7 +356,7 @@ int noimage; * Check for a predefined cset; use keyword name if found. */ if ((csn = csname(dp)) != NULL) { - fprintf(f, csn); + fprintf(f, "%s", csn); return; } /* @@ -628,12 +548,6 @@ int noimage; fprintf(f, "&random = "); else if (VarLoc(*dp) == &kywd_trc) fprintf(f, "&trace = "); - -#ifdef FncTrace - else if (VarLoc(*dp) == &kywd_ftrc) - fprintf(f, "&ftrace = "); -#endif /* FncTrace */ - else if (VarLoc(*dp) == &kywd_dmp) fprintf(f, "&dump = "); else if (VarLoc(*dp) == &kywd_err) @@ -642,14 +556,6 @@ int noimage; } kywdevent: { -#ifdef MultiThread - if (VarLoc(*dp) == &curpstate->eventsource) - fprintf(f, "&eventsource = "); - else if (VarLoc(*dp) == &curpstate->eventcode) - fprintf(f, "&eventcode = "); - else if (VarLoc(*dp) == &curpstate->eventval) - fprintf(f, "&eventval = "); -#endif /* MultiThread */ outimage(f, VarLoc(*dp), noimage); } @@ -682,8 +588,13 @@ int noimage; outimage(f, dp, noimage); putc(')', f); } - else if (Type(*dp) == T_External) - fprintf(f, "external(%d)",((struct b_external *)BlkLoc(*dp))->blksize); + else if (Type(*dp) == T_External) { + q = callextfunc(&extlimage, dp, NULL); /* get image as a string */ + i = StrLen(q); + s = StrLoc(q); + while (i-- > 0) + putc(*s++, f); + } else if (Type(*dp) <= MaxType) fprintf(f, "%s", blkname[Type(*dp)]); else @@ -848,7 +759,6 @@ int (*compar)(); return 0; } -#if !COMPILER /* * qtos - convert a qualified string named by *dp to a C-style string. * Put the C-style string in sbuf if it will fit, otherwise put it @@ -883,9 +793,7 @@ char *sbuf; } return Succeeded; } -#endif /* !COMPILER */ -#ifdef Coexpr /* * pushact - push actvtr on the activator stack of ce */ @@ -895,10 +803,6 @@ struct b_coexpr *ce, *actvtr; struct astkblk *abp = ce->es_actstk, *nabp; struct actrec *arp; -#ifdef MultiThread - abp->arec[0].activator = actvtr; -#else /* MultiThread */ - /* * If the last activator is the same as this one, just increment * its count. @@ -924,10 +828,8 @@ struct b_coexpr *ce, *actvtr; arp->acount = 1; arp->activator = actvtr; ce->es_actstk = abp; -#endif /* MultiThread */ return Succeeded; } -#endif /* Coexpr */ /* * popact - pop the most recent activator from the activator stack of ce @@ -936,17 +838,10 @@ struct b_coexpr *ce, *actvtr; struct b_coexpr *popact(ce) struct b_coexpr *ce; { - -#ifdef Coexpr - struct astkblk *abp = ce->es_actstk, *oabp; struct actrec *arp; struct b_coexpr *actvtr; -#ifdef MultiThread - return abp->arec[0].activator; -#else /* MultiThread */ - /* * If the current stack block is empty, pop it. */ @@ -971,15 +866,8 @@ struct b_coexpr *ce; ce->es_actstk = abp; return actvtr; -#endif /* MultiThread */ - -#else /* Coexpr */ - syserr("popact() called, but co-expressions not implemented"); -#endif /* Coexpr */ - } -#ifdef Coexpr /* * topact - return the most recent activator of ce. */ @@ -988,48 +876,14 @@ struct b_coexpr *ce; { struct astkblk *abp = ce->es_actstk; -#ifdef MultiThread - return abp->arec[0].activator; -#else /* MultiThread */ if (abp->nactivators == 0) abp = abp->astk_nxt; return abp->arec[abp->nactivators-1].activator; -#endif /* MultiThread */ } -#ifdef DeBugIconx -/* - * dumpact - dump an activator stack - */ -void dumpact(ce) -struct b_coexpr *ce; -{ - struct astkblk *abp = ce->es_actstk; - struct actrec *arp; - int i; - - if (abp) - fprintf(stderr, "Ce %ld ", (long)ce->id); - while (abp) { - fprintf(stderr, "--- Activation stack block (%x) --- nact = %d\n", - abp, abp->nactivators); - for (i = abp->nactivators; i >= 1; i--) { - arp = &abp->arec[i-1]; - /*for (j = 1; j <= arp->acount; j++)*/ - fprintf(stderr, "co-expression_%ld(%d)\n", (long)(arp->activator->id), - arp->acount); - } - abp = abp->astk_nxt; - } -} -#endif /* DeBugIconx */ -#endif /* Coexpr */ - -#if !COMPILER /* * findline - find the source line number associated with the ipc */ -#ifdef SrcColumnInfo int findline(ipc) word *ipc; { @@ -1042,19 +896,12 @@ word *ipc; } int findloc(ipc) -#else /* SrcColumnInfo */ -int findline(ipc) -#endif /* SrcColumnInfo */ word *ipc; { uword ipc_offset; uword size; struct ipc_line *base; - -#ifndef MultiThread extern struct ipc_line *ilines, *elines; -#endif /* MultiThread */ - static int two = 2; /* some compilers generate bad code for division by a constant that is a power of two ... */ @@ -1084,11 +931,7 @@ int line; { uword size; struct ipc_line *base; - -#ifndef MultiThread extern struct ipc_line *ilines, *elines; -#endif /* MultiThread */ - static int two = 2; /* some compilers generate bad code for division by a constant that is a power of two ... */ @@ -1113,10 +956,7 @@ word *ipc; { uword ipc_offset; struct ipc_fname *p; - -#ifndef MultiThread extern struct ipc_fname *filenms, *efilenms; -#endif /* MultiThread */ if (!InRange(code,ipc,ecode)) return "?"; @@ -1130,7 +970,6 @@ word *ipc; /*NOTREACHED*/ return 0; /* avoid gcc warning */ } -#endif /* !COMPILER */ /* * doimage(c,q) - allocate character c in string space, with escape @@ -1249,7 +1088,6 @@ dptr dp1, dp2; } integer: { -#ifdef LargeInts if (Type(source) == T_Lrgint) { word slen; word dlen; @@ -1271,9 +1109,6 @@ dptr dp1, dp2; } else cnv: string(source, *dp2); -#else /* LargeInts */ - cnv:string(source, *dp2); -#endif /* LargeInts */ } real: { @@ -1472,16 +1307,9 @@ dptr dp1, dp2; } default: - if (Type(*dp1) == T_External) { - /* - * For now, just produce "external(n)". - */ - sprintf(sbuf, "external(%ld)", (long)BlkLoc(*dp1)->externl.blksize); - len = strlen(sbuf); - Protect(t = alcstr(sbuf, len), return Error); - StrLoc(*dp2) = t; - StrLen(*dp2) = len; - } + if (Type(*dp1) == T_External) { + *dp2 = callextfunc(&extlimage, dp1, NULL); + } else { ReturnErrVal(123, source, Error); } @@ -1685,100 +1513,6 @@ word a; return -a; } -#if COMPILER -/* - * sig_rsm - standard success continuation that just signals resumption. - */ - -int sig_rsm() - { - return A_Resume; - } - -/* - * cmd_line - convert command line arguments into a list of strings. - */ -void cmd_line(argc, argv, rslt) -int argc; -char **argv; -dptr rslt; - { - tended struct b_list *hp; - register word i; - register struct b_lelem *bp; /* need not be tended */ - - /* - * Skip the program name. - */ - --argc; - ++argv; - - /* - * Allocate the list and a list block. - */ - Protect(hp = alclist(argc), fatalerr(0,NULL)); - Protect(bp = alclstb(argc, (word)0, argc), fatalerr(0,NULL)); - - /* - * Make the list block just allocated into the first and last blocks - * for the list. - */ - hp->listhead = hp->listtail = (union block *)bp; -#ifdef ListFix - bp->listprev = bp->listnext = (union block *)hp; -#endif /* ListFix */ - - /* - * Copy the arguments into the list - */ - for (i = 0; i < argc; ++i) { - StrLen(bp->lslots[i]) = strlen(argv[i]); - StrLoc(bp->lslots[i]) = argv[i]; - } - - rslt->dword = D_List; - rslt->vword.bptr = (union block *) hp; - } - -/* - * varargs - construct list for use in procedures with variable length - * argument list. - */ -void varargs(argp, nargs, rslt) -dptr argp; -int nargs; -dptr rslt; - { - tended struct b_list *hp; - register word i; - register struct b_lelem *bp; /* need not be tended */ - - /* - * Allocate the list and a list block. - */ - Protect(hp = alclist(nargs), fatalerr(0,NULL)); - Protect(bp = alclstb(nargs, (word)0, nargs), fatalerr(0,NULL)); - - /* - * Make the list block just allocated into the first and last blocks - * for the list. - */ - hp->listhead = hp->listtail = (union block *)bp; -#ifdef ListFix - bp->listprev = bp->listnext = (union block *)hp; -#endif /* ListFix */ - - /* - * Copy the arguments into the list - */ - for (i = 0; i < nargs; i++) - deref(&argp[i], &bp->lslots[i]); - - rslt->dword = D_List; - rslt->vword.bptr = (union block *) hp; - } -#endif /* COMPILER */ - /* * retderef - Dereference local variables and substrings of local * string-valued variables. This is used for return, suspend, and diff --git a/src/runtime/rmswin.ri b/src/runtime/rmswin.ri index 3471fd3..317e95f 100644 --- a/src/runtime/rmswin.ri +++ b/src/runtime/rmswin.ri @@ -232,7 +232,7 @@ FILE *wopen(char *name, struct b_list *lp, dptr attr, int n, int *err_idx) if (! winInitialized++) { BORDWIDTH = FRAMEWIDTH * 2; - BORDHEIGHT = TITLEHEIGHT + FRAMEHEIGHT * 2 - 1; + BORDHEIGHT = TITLEHEIGHT + FRAMEHEIGHT * 2; GetCPInfo(CP_ACP, &cpinfo); MAXBYTESPERCHAR = cpinfo.MaxCharSize; } @@ -299,10 +299,10 @@ FILE *wopen(char *name, struct b_list *lp, dptr attr, int n, int *err_idx) palette = CreatePalette(logpal); if ((scp = malloc(2 * sizeof (struct wcolor))) == NULL) return NULL; scp[0].c = RGB(0,0,0); - scp[0].type = SHARED; + scp[0].type = CSHARED; strcpy(scp[0].name, "black"); scp[1].c = RGB(255,255,255); - scp[1].type = SHARED; + scp[1].type = CSHARED; strcpy(scp[1].name, "white"); } oldfont = SelectObject(hdc, wc->font->font); @@ -1552,7 +1552,7 @@ int alc_rgb(wbp w, SysColor rgb) LOGPALETTE lp; if (palette) { for (i=0; i < numColors; i++) { - if (rgb == scp[i].c && scp[i].type == SHARED) break; + if (rgb == scp[i].c && scp[i].type == CSHARED) break; } if (i == numColors) { numColors++; @@ -1563,7 +1563,7 @@ int alc_rgb(wbp w, SysColor rgb) scp = realloc(scp, numColors * sizeof(struct wcolor)); if (scp == NULL) { numColors--; return Failed; } scp[numColors - 1].c = rgb; - scp[numColors - 1].type = SHARED; + scp[numColors - 1].type = CSHARED; sprintf(scp[numColors - 1].name, "%d,%d,%d", RED(rgb), GREEN(rgb), BLUE(rgb)); lp.palNumEntries = 1; @@ -2529,10 +2529,10 @@ HBITMAP loadimage(wbp w, char *filename, unsigned int *width, if ((scp = malloc(2 * sizeof (struct wcolor))) == NULL) return NULL; scp[0].c = RGB(0,0,0); - scp[0].type = SHARED; + scp[0].type = CSHARED; strcpy(scp[0].name, "black"); scp[1].c = RGB(255,255,255); - scp[1].type = SHARED; + scp[1].type = CSHARED; strcpy(scp[1].name, "white"); } else { @@ -2570,7 +2570,7 @@ char *get_mutable_name(wbp w, int mute_index) char *tmp; PALETTEENTRY pe; - if (-mute_index > numColors || scp[-mute_index].type != MUTABLE) { + if (-mute_index > numColors || scp[-mute_index].type != CMUTABLE) { return NULL; } @@ -2642,7 +2642,7 @@ int mutable_color(wbp w, dptr argv, int argc, int *retval) } scp[numColors-1].c = -(numColors-1); sprintf(scp[numColors-1].name, "%d:", -(numColors-1)); - scp[numColors-1].type = MUTABLE; + scp[numColors-1].type = CMUTABLE; if (ResizePalette(palette, numColors) == 0) { FREE_STDLOCALS(w); return Failed; diff --git a/src/runtime/rstruct.r b/src/runtime/rstruct.r index 22ab704..acf72f4 100644 --- a/src/runtime/rstruct.r +++ b/src/runtime/rstruct.r @@ -91,10 +91,6 @@ word i, j; Protect(lp2 = (struct b_list *) alclist(size), return Error); Protect(bp2 = (struct b_lelem *)alclstb(nslots,(word)0,size), return Error); lp2->listhead = lp2->listtail = (union block *) bp2; -#ifdef ListFix - bp2->listprev = bp2->listnext = (union block *) lp2; -#endif /* ListFix */ - cpslots(dp1, bp2->lslots, i, j); /* @@ -102,95 +98,9 @@ word i, j; */ dp2->dword = D_List; BlkLoc(*dp2) = (union block *) lp2; - EVValD(dp2, E_Lcreate); return Succeeded; } -#ifdef TableFix -/* - * cpset(dp1,dp2,n) - copy set dp1 to dp2, reserving memory for n entries. - */ -int cpset(dp1, dp2, n) -dptr dp1, dp2; -word n; - { - int i = cphash(dp1, dp2, n, T_Set); - EVValD(dp2, E_Screate); - return i; - } - -int cptable(dp1, dp2, n) -dptr dp1, dp2; -word n; - { - int i = cphash(dp1, dp2, n, T_Table); - BlkLoc(*dp2)->table.defvalue = BlkLoc(*dp1)->table.defvalue; - EVValD(dp2, E_Tcreate); - return i; - } - -int cphash(dp1, dp2, n, tcode) -dptr dp1, dp2; -word n; -int tcode; - { - union block *src; - tended union block *dst; - tended struct b_slots *seg; - tended struct b_selem *ep, *prev; - struct b_selem *se; - register word slotnum; - register int i; - - /* - * Make a new set organized like dp1, with room for n elements. - */ - dst = hmake(tcode, BlkLoc(*dp1)->set.mask + 1, n); - if (dst == NULL) - return Error; - /* - * Copy the header and slot blocks. - */ - src = BlkLoc(*dp1); - dst->set.size = src->set.size; /* actual set size */ - dst->set.mask = src->set.mask; /* hash mask */ - for (i = 0; i < HSegs && src->set.hdir[i] != NULL; i++) - memcpy((char *)dst->set.hdir[i], (char *)src->set.hdir[i], - src->set.hdir[i]->blksize); - /* - * Work down the chain of element blocks in each bucket - * and create identical chains in new set. - */ - for (i = 0; i < HSegs && (seg = dst->set.hdir[i]) != NULL; i++) - for (slotnum = segsize[i] - 1; slotnum >= 0; slotnum--) { - prev = NULL; - for (ep = (struct b_selem *)seg->hslots[slotnum]; - ep != NULL && BlkType(ep) != T_Table; - ep = (struct b_selem *)ep->clink) { - if (tcode == T_Set) { - Protect(se = alcselem(&ep->setmem, ep->hashnum), return Error); - se->clink = ep->clink; - } - else { - Protect(se = (struct b_selem *)alctelem(), return Error); - *(struct b_telem *)se = *(struct b_telem *)ep; /* copy table entry */ - if (BlkType(se->clink) == T_Table) - se->clink = dst; - } - if (prev == NULL) - seg->hslots[slotnum] = (union block *)se; - else - prev->clink = (union block *)se; - prev = se; - } - } - dp2->dword = tcode | D_Typecode | F_Ptr; - BlkLoc(*dp2) = dst; - if (TooSparse(dst)) - hshrink(dst); - return Succeeded; - } -#else /* TableFix */ /* * cpset(dp1,dp2,n) - copy set dp1 to dp2, reserving memory for n entries. */ @@ -243,10 +153,8 @@ word n; BlkLoc(*dp2) = dst; if (TooSparse(dst)) hshrink(dst); - Desc_EVValD(dst, E_Screate, D_Set); return Succeeded; } -#endif /* TableFix */ /* * hmake - make a hash structure (Set or Table) with a given number of slots. @@ -281,13 +189,6 @@ word nslots, nelem; for (; seg >= 0; seg--) { Protect(segp = alcsegment(segsize[seg]), return NULL); blk->set.hdir[seg] = segp; -#ifdef TableFix - if (tcode == T_Table) { - int j; - for (j = 0; j < segsize[seg]; j++) - segp->hslots[j] = blk; - } -#endif /* TableFix */ } blk->set.mask = nslots - 1; return blk; @@ -384,15 +285,9 @@ union block *ep; * has same hash value as the current one, in which case we defer it * by doing nothing now. */ -#ifdef TableFix - if (bp->table.mask != s->tmask && - (ep->selem.clink == NULL || BlkType(ep->telem.clink) == T_Table || - ep->telem.clink->telem.hashnum != ep->telem.hashnum)) { -#else /* TableFix */ if (bp->table.mask != s->tmask && (ep->selem.clink == NULL || ep->telem.clink->telem.hashnum != ep->telem.hashnum)) { -#endif /* TableFix */ /* * Yes, they did split. Make a note of the current state. */ @@ -414,12 +309,7 @@ union block *ep; * element, because it may have moved to a new segment. */ ep = bp->table.hdir[s->segnum]->hslots[s->slotnum]; -#ifdef TableFix - while (ep != NULL && BlkType(ep) != T_Table && - ep->telem.hashnum <= hn) -#else /* TableFix */ while (ep != NULL && ep->telem.hashnum <= hn) -#endif /* TableFix */ ep = ep->telem.clink; } @@ -429,22 +319,14 @@ union block *ep; * that have identical hash numbers. Find the next element in * the current hash chain. */ -#ifdef TableFix - if (ep != NULL && BlkType(ep) != T_Table) /* NULL on very first call */ -#else /* TableFix */ if (ep != NULL) /* already NULL on very first call */ -#endif /* TableFix */ ep = ep->telem.clink; /* next element in chain, if any */ } /* * If we don't yet have an element, search successive slots. */ -#ifdef TableFix - while (ep == NULL || BlkType(ep) == T_Table) { -#else /* TableFix */ while (ep == NULL) { -#endif /* TableFix */ /* * Move to the next slot and pick the first entry. */ @@ -470,12 +352,7 @@ union block *ep; * This chain was split from its parent while the parent was * being processed. Skip past elements already processed. */ -#ifdef TableFix - while (ep != NULL && BlkType(ep) != T_Table && - ep->telem.hashnum <= s->sghash[i]) -#else /* TableFix */ while (ep != NULL && ep->telem.hashnum <= s->sghash[i]) -#endif /* TableFix */ ep = ep->telem.clink; } } @@ -484,9 +361,6 @@ union block *ep; /* * Return the element. */ -#ifdef TableFix - if (ep && BlkType(ep) == T_Table) ep = NULL; -#endif /* TableFix */ return ep; } @@ -508,25 +382,12 @@ union block *bp; return; /* can't split further */ newslots = ps->mask + 1; Protect(newseg = alcsegment(newslots), return); -#ifdef TableFix - if (BlkType(bp) == T_Table) { - int j; - for(j=0; j<newslots; j++) newseg->hslots[j] = bp; - } -#endif /* TableFix */ - curslot = newseg->hslots; for (segnum = 0; (seg = ps->hdir[segnum]) != NULL; segnum++) for (slotnum = 0; slotnum < segsize[segnum]; slotnum++) { tp0 = &seg->hslots[slotnum]; /* ptr to tail of old slot */ tp1 = curslot++; /* ptr to tail of new slot */ -#ifdef TableFix - for (ep = *tp0; - ep != NULL && BlkType(ep) != T_Table; - ep = ep->selem.clink) { -#else /* TableFix */ for (ep = *tp0; ep != NULL; ep = ep->selem.clink) { -#endif /* TableFix */ if ((ep->selem.hashnum & newslots) == 0) { *tp0 = ep; /* element does not move */ tp0 = &ep->selem.clink; @@ -536,14 +397,7 @@ union block *bp; tp1 = &ep->selem.clink; } } -#ifdef TableFix - if ( BlkType(bp) == T_Table ) - *tp0 = *tp1 = bp; - else - *tp0 = *tp1 = NULL; -#else /* TableFix */ *tp0 = *tp1 = NULL; -#endif /* TableFix */ } ps->hdir[segnum] = newseg; ps->mask = (ps->mask << 1) | 1; @@ -578,12 +432,7 @@ union block *bp; tp = &seg->hslots[slotnum]; /* tail pointer */ ep0 = seg->hslots[slotnum]; /* lower slot entry pointer */ ep1 = *uppslot++; /* upper slot entry pointer */ -#ifdef TableFix - while (ep0 != NULL && BlkType(ep0) != T_Table && - ep1 != NULL && BlkType(ep1) != T_Table) -#else /* TableFix */ while (ep0 != NULL && ep1 != NULL) -#endif /* TableFix */ if (ep0->selem.hashnum < ep1->selem.hashnum) { *tp = ep0; tp = &ep0->selem.clink; @@ -594,20 +443,12 @@ union block *bp; tp = &ep1->selem.clink; ep1 = ep1->selem.clink; } -#ifdef TableFix - while (ep0 != NULL && BlkType(ep0) != T_Table) { -#else /* TableFix */ while (ep0 != NULL) { -#endif /* TableFix */ *tp = ep0; tp = &ep0->selem.clink; ep0 = ep0->selem.clink; } -#ifdef TableFix - while (ep1 != NULL && BlkType(ep1) != T_Table) { -#else /* TableFix */ while (ep1 != NULL) { -#endif /* TableFix */ *tp = ep1; tp = &ep1->selem.clink; ep1 = ep1->selem.clink; @@ -640,11 +481,7 @@ int *res; /* pointer to integer result flag */ * Look for x in the hash chain. */ *res = 0; -#ifdef TableFix - while ((pe = (struct b_selem *)*lp) != NULL && BlkType(pe) != T_Table) { -#else /* TableFix */ while ((pe = (struct b_selem *)*lp) != NULL) { -#endif /* TableFix */ eh = pe->hashnum; if (eh > hn) /* too far - it isn't there */ return lp; diff --git a/src/runtime/rsys.r b/src/runtime/rsys.r index f4bdfc1..83f6380 100644 --- a/src/runtime/rsys.r +++ b/src/runtime/rsys.r @@ -126,16 +126,11 @@ dptr d; int idelay(n) int n; { - #if MSWIN - Sleep(n); - return Succeeded; - #else /* MSWIN */ - struct timeval t; - t.tv_sec = n / 1000; - t.tv_usec = (n % 1000) * 1000; - select(1, NULL, NULL, NULL, &t); - return Succeeded; - #endif /* MSWIN */ + struct timeval t; + t.tv_sec = n / 1000; + t.tv_usec = (n % 1000) * 1000; + select(1, NULL, NULL, NULL, &t); + return Succeeded; } #ifdef KeyboardFncs diff --git a/src/runtime/rwindow.r b/src/runtime/rwindow.r index 752baa2..0ad4ddc 100644 --- a/src/runtime/rwindow.r +++ b/src/runtime/rwindow.r @@ -10,7 +10,6 @@ static int sicmp (siptr sip1, siptr sip2); int canvas_serial, context_serial; -#ifndef MultiThread struct descrip amperX = {D_Integer}; struct descrip amperY = {D_Integer}; struct descrip amperCol = {D_Integer}; @@ -19,8 +18,6 @@ struct descrip amperInterval = {D_Integer}; struct descrip lastEventWin = {D_Null}; int lastEvFWidth = 0, lastEvLeading = 0, lastEvAscent = 0; uword xmod_control, xmod_shift, xmod_meta; -#endif /* MultiThread */ - /* * subscript the already-processed-events "queue" to index i. diff --git a/src/runtime/rxrsc.ri b/src/runtime/rxrsc.ri index c99edeb..199468c 100644 --- a/src/runtime/rxrsc.ri +++ b/src/runtime/rxrsc.ri @@ -16,7 +16,7 @@ int fontcmp(char *font1, char *font2, int size, int flags); /* check for color match */ #define CMATCH(cp, rr, gg, bb) \ ((cp)->r == (rr) && (cp)->g == (gg) && (cp->b) == (bb) && \ - (cp)->type == SHARED && (cp)->refcount > 0) + (cp)->type == CSHARED && (cp)->refcount > 0) /* * Allocate a color given linear r, g, b. Colors are shared on a @@ -122,7 +122,7 @@ int is_iconcolor; cp->g = g; cp->b = b; cp->c = color.pixel; - cp->type = SHARED; + cp->type = CSHARED; /* * Remember in window color list, too, if not TrueColor visual. */ @@ -234,7 +234,7 @@ wbp w1, w2; for (i1 = 0; i1 < ws1->numColors; i1++) { j = ws1->theColors[i1]; - if (wd->colrptrs[j]->refcount > 0 && wd->colrptrs[j]->type != MUTABLE) { + if (wd->colrptrs[j]->refcount > 0 && wd->colrptrs[j]->type != CMUTABLE) { for (i2 = 0; i2 < ws2->numColors; i2++) { if (j == ws2->theColors[i2]) break; @@ -315,33 +315,11 @@ int extent; */ if (((extent==0) && (wd->colrptrs[j] == w->context->fg)) || ((extent==0) && (wd->colrptrs[j] == w->context->bg)) || - (wd->colrptrs[j]->type == MUTABLE)) { + (wd->colrptrs[j]->type == CMUTABLE)) { theColors[numSaved++] = j; continue; } -#ifdef FreeColorFix - /* - * don't free ANY context's fg or bg - */ - { - wcp wc; int numhits = 0; - for(wc=wcntxts; wc; wc=wc->next) { - if ((wc->fg == wd->colrptrs[j]) || - (wc->bg == wd->colrptrs[j])) { - if (numhits == 0) - theColors[numSaved++] = j; - numhits++; - } - } - if (numhits) { - if (numhits > wd->colrptrs[j]->refcount) - wd->colrptrs[j]->refcount = numhits; - continue; - } - } -#endif /* FreeColorFix */ - if (--(wd->colrptrs[j]->refcount) == 0) { toFree[freed++] = wd->colrptrs[j]->c; } @@ -428,7 +406,7 @@ char *s; cp = wd->colrptrs[0]; strcpy(cp->name,"black"); - cp->type = SHARED; + cp->type = CSHARED; cp->r = cp->g = cp->b = 0; color.red = color.green = color.blue = 0; if (XAllocColor(wd->display, wd->cmap, &color)) @@ -438,7 +416,7 @@ char *s; cp = wd->colrptrs[1]; strcpy(cp->name,"white"); - cp->type = SHARED; + cp->type = CSHARED; cp->r = cp->g = cp->b = 65535; color.red = color.green = color.blue = 65535; if (XAllocColor(wd->display, wd->cmap, &color)) @@ -685,7 +663,7 @@ int size, flags; */ p = xlfd_field(fontlist[champ], XLFD_Size); if (p[0] == '0' && p[1] == '-') - sprintf(fontspec, "%.*s%d%s", p - fontlist[champ], + sprintf(fontspec, "%.*s%d%s", (int) (p - fontlist[champ]), fontlist[champ], bestsize, p + 1); else strcpy(fontspec, fontlist[champ]); diff --git a/src/runtime/rxwin.ri b/src/runtime/rxwin.ri index c2dc48c..3db8086 100644 --- a/src/runtime/rxwin.ri +++ b/src/runtime/rxwin.ri @@ -1140,22 +1140,7 @@ char *s; } else { if (ws->iconic != IconicState) { -#ifdef Iconify - if (ws->win == (Window) NULL) { - wmap(w); - } - XIconifyWindow(ws->display->display, ws->win, ws->display->screen); - XSync(stddpy, False); - while (ws->iconic != IconicState) - if ((hm = handle_misc(wd, NULL)) < 1) { - if (hm == -1) return Error; - else if (hm == 0) { - return Failed; - } - } -#else /* Iconify */ return Failed; -#endif /* Iconify */ } } } @@ -1265,11 +1250,7 @@ char *s; } else { if (ws->iconic != IconicState) { -#ifdef Iconify - XIconifyWindow(ws->display->display, ws->win, ws->display->screen); -#else /* Iconify */ return Failed; -#endif /* Iconify */ } } } @@ -1509,7 +1490,7 @@ int fg; return setfgrgb(w, r * 257, g * 257, b * 257); } for (i = 2; i < wd->numColors; i++) - if (wd->colrptrs[i]->type == MUTABLE && wd->colrptrs[i]->c == -fg - 1) + if (wd->colrptrs[i]->type == CMUTABLE && wd->colrptrs[i]->c == -fg - 1) break; if (i == wd->numColors) return Failed; wc->fg = wd->colrptrs[i]; @@ -1562,7 +1543,7 @@ int bg; return setbgrgb(w, r * 257, g * 257, b * 257); } for (i = 2; i < wd->numColors; i++) - if (wd->colrptrs[i]->type == MUTABLE && wd->colrptrs[i]->c == -bg - 1) + if (wd->colrptrs[i]->type == CMUTABLE && wd->colrptrs[i]->c == -bg - 1) break; if (i == wd->numColors) return Failed; wc->bg = wd->colrptrs[i]; @@ -2287,7 +2268,7 @@ int *retval; i = alc_centry(wd); if (i == 0) return Failed; - wd->colrptrs[i]->type = MUTABLE; + wd->colrptrs[i]->type = CMUTABLE; wd->colrptrs[i]->c = pixels[0]; /* save color index as "name", followed by a null string for value */ @@ -2351,7 +2332,7 @@ int mute_index; d = dp->display; for (i = 2; i < dp->numColors; i++) - if (dp->colrptrs[i]->type == MUTABLE + if (dp->colrptrs[i]->type == CMUTABLE && dp->colrptrs[i]->c == - mute_index - 1) break; if (i == dp->numColors) @@ -2390,7 +2371,7 @@ int mute_index; d = dp->display; for (i = 2; i < dp->numColors; i++) - if (dp->colrptrs[i]->type == MUTABLE + if (dp->colrptrs[i]->type == CMUTABLE && dp->colrptrs[i]->c == - mute_index - 1) break; if (i != dp->numColors) @@ -2416,7 +2397,7 @@ char *s; for (i = 2; i < dp->numColors; i++) if (dp->colrptrs[i]->r == color.red && dp->colrptrs[i]->g == color.green - && dp->colrptrs[i]->b == color.blue && dp->colrptrs[i]->type != MUTABLE) + && dp->colrptrs[i]->b == color.blue && dp->colrptrs[i]->type != CMUTABLE) break; if (i != dp->numColors) free_xcolor(w, dp->colrptrs[i]->c); @@ -2794,7 +2775,7 @@ struct imgmem *imem; for (cpp = wd->colrptrs ; cpp < wd->colrptrs + wd->numColors; cpp++) { if ((*cpp)->c == c) { - if ((*cpp)->type == MUTABLE) + if ((*cpp)->type == CMUTABLE) *rv = -c - 1; else { *rv = 1; diff --git a/tests/Makefile b/tests/Makefile index 1082665..af083a8 100644 --- a/tests/Makefile +++ b/tests/Makefile @@ -1,14 +1,11 @@ # Makefile for testing Icon -# The default is to run all tests, using icont. +# The default is to run all tests. Test Test-icont: ; cd general; $(MAKE) Test Samples Samples-icont: ; cd general; $(MAKE) Samples -Test-iconc: ; cd general; $(MAKE) Test-iconc -Samples-iconc: ; cd general; $(MAKE) Samples-iconc - # Clean up. diff --git a/tests/README b/tests/README index ce7ac17..9b1c30b 100644 --- a/tests/README +++ b/tests/README @@ -1,5 +1,4 @@ -The sub-directories here contain various test material for -Version 9.4 of Icon. +The sub-directories here contain various test material for Version 9.5 of Icon. bench benchmarking suite general main test suite, including quick "samples" subset diff --git a/tests/bench/Comp-iconc b/tests/bench/Comp-iconc deleted file mode 100755 index eb5dafe..0000000 --- a/tests/bench/Comp-iconc +++ /dev/null @@ -1,5 +0,0 @@ -for i in $* -do - echo compiling $i - ../../bin/iconc -s -o $i-c $i -done diff --git a/tests/bench/Run-icont b/tests/bench/Execute-icont index e81defd..e81defd 100755 --- a/tests/bench/Run-icont +++ b/tests/bench/Execute-icont diff --git a/tests/bench/Makefile b/tests/bench/Makefile index d0e4b6f..00afb52 100644 --- a/tests/bench/Makefile +++ b/tests/bench/Makefile @@ -1,25 +1,13 @@ -what: - @echo "What do you want to make?" +default: benchmark -benchmark: - $(MAKE) benchmark-icont - - -benchmark-iconc: - $(MAKE) compile-iconc run-iconc check-iconc - -compile-iconc: - sh Comp-iconc concord deal ipxref queens rsg -run-iconc: - sh Run-iconc - -rerun-iconc: - sh ReRun-iconc - -check-iconc: - grep elapsed *-c.out +micro microbench microbenchmark: + ../../bin/icon micro.icn >micro.out + ../../bin/icon micsum.icn micro.out >micro.sum + cat micro.sum +benchmark: + $(MAKE) benchmark-icont benchmark-icont: $(MAKE) translate-icont compile-icont run-icont check-icont @@ -31,7 +19,7 @@ compile-icont: sh Comp-icont concord deal ipxref queens rsg run-icont: - sh Run-icont + sh Execute-icont rerun-icont: sh ReRun-icont @@ -40,5 +28,4 @@ check-icont: grep elapsed *-t.out Clean: - rm -f *.out concord-[ct] deal-[ct] ipxref-[ct] queens-[ct] \ - rsg-[ct] *.u? + rm -f *.out *.sum *-t *.u? diff --git a/tests/bench/ReRun-iconc b/tests/bench/ReRun-iconc deleted file mode 100755 index 1695aa2..0000000 --- a/tests/bench/ReRun-iconc +++ /dev/null @@ -1,10 +0,0 @@ -echo Running concord ... -./concord-c <concord.dat >>concord-c.out -echo Running deal ... -./deal-c -h 500 >>deal-c.out -echo Running ipxref ... -./ipxref-c <ipxref.icn >>ipxref-c.out -echo Running queens ... -./queens-c -n9 >>queens-c.out -echo Running rsg ... -./rsg-c <rsg.dat >>rsg-c.out diff --git a/tests/bench/Run-iconc b/tests/bench/Run-iconc deleted file mode 100755 index 4a8c58d..0000000 --- a/tests/bench/Run-iconc +++ /dev/null @@ -1,10 +0,0 @@ -echo Running concord ... -./concord-c <concord.dat >concord-c.out -echo Running deal ... -./deal-c -h 500 >deal-c.out -echo Running ipxref ... -./ipxref-c <ipxref.icn >ipxref-c.out -echo Running queens ... -./queens-c -n9 >queens-c.out -echo Running rsg ... -./rsg-c <rsg.dat >rsg-c.out diff --git a/tests/bench/micro.icn b/tests/bench/micro.icn new file mode 100644 index 0000000..7654b7a --- /dev/null +++ b/tests/bench/micro.icn @@ -0,0 +1,976 @@ +# micro.icn -- microbenchmark timings of Icon operations +# +# From the Jcon distribution: +# 14-feb-98/gmt +# 13-mar-98/gmt +# 25-mar-98/gmt +# 2-apr-98/gmt +# 3-apr-98/gmt +# Revised for Icon v9: +# 5-nov-09/gmt +# +# usage: icon micro.icn interval +# +# Various Icon operations are executed inside an "every 1 to n" loop, +# with n scaled to execute the loop for at least <interval> seconds. +# Timings are based on &time, which must be meaningful or all bets are off. +# +# For each operation, execution time per iteration is given in nanoseconds. +# Automatic calibration produces a delay of a few seconds before the +# first line is output. This first line reports the measured overhead +# of an empty loop, which is subtracted from subsequent values. +# +# Timings labeled "nothing" are remeasurements of the empty loop. +# They should ideally be zero; deviations indicate inaccuracies +# and inconsistencies in the timing measurements. + + +$define DefaultTime 1.0 # default measurement interval, in seconds +$define MinOvhTime 1.0 # minimum interval for overhead measurement +$define NumOvhLoops 5 # number of overhead measurements to take + +global looptime # expected loop time, in msec +global overhead # measured loop overhead, in nsec + +global sink # output file for I/O tests + + +procedure main(args) + local olist, ovhtime + + looptime := integer(1000 * (args[1] | DefaultTime)) + sink := open("/dev/null", "w") + + # use median of five tries for overhead value + ovhtime := looptime + ovhtime <:= integer(1000 * MinOvhTime) + olist := list() + every 1 to NumOvhLoops do { + writes(&errout,".") + put(olist, measure(nothing, ovhtime)) + } + overhead := sort(olist)[1 + (*olist - 1) / 2] # median + write(right(overhead, 10), " overhead") + + report(nothing) + report(nothing) + report(nothing) + + report(globasgn) + report(statasgn) + report(loclasgn) + + report(if0) + report(case3) + report(nulltest) + report(typef) + report(imagef) + report(everyto) + report(everyalt) + report(conj5) + report(nullfunc) + report(listcall) + report(marshal) + report(evsusp) + + report(tointeger) + report(intcoerce) + report(uplus) + report(tostring) + report(strcoerce) + report(absf) + report(intadd) + report(addfunc) + report(intpow) + report(intcmp) + report(rfact0) + report(rfact10) + report(rfib5) + report(prslow) + + report(toreal) + report(realcoerce) + report(uplusr) + report(rtostring) + report(strcoercer) + report(realcmp) + report(sqrtf) + report(cosf) + report(logf) + + report(charf) + report(ordf) + report(strsize) + report(strpick) + report(strbang) + report(strsub) + report(substr) + report(subsasg) + report(strcmp) + report(strident) + report(concat) + + report(reversef) + report(trimf) + report(replf) + report(leftf) + report(centerf) + report(rightf) + report(entabf) + report(detabf) + report(mapf) + + report(nullscan) + report(movef) + report(tabf) + report(matchf) + report(tabmat) + report(posf) + report(anyf) + report(manyf) + report(uptof) + report(findf) + report(balf) + + report(tocset) + report(cssize) + report(cscompl) + + report(lcreate) + report(lconst) + report(lcopy) + report(lsort) + report(lsize) + report(lpick) + report(lbang) + report(lsubscr) + report(putget) + report(putget12) + report(pushpop) + report(pushpop12) + + report(setcreate) + report(setcopy) + report(setmember) + report(setinsert) + report(setinsdel) + report(setbang) + report(setpick) + + report(tblcreate) + report(tblsub) + report(tblasgn) + + report(recconstr) + report(reccopy) + report(recfield) + report(bigfield) + + report(readz) + report(writecon) + report(writestr) + + report(cxcreate) + report(cxget) + + report(nothing) + report(nothing) + report(nothing) + + write(&errout) +end + +procedure report(proc) + local label + label := proc() + writes(&errout, ".") # progress indicator + write(right(measure(proc, looptime) - overhead, 10), " ", label) + return +end + +procedure measure(proc, looptime) + local n, t1, t2, dt, nsec + + proc(1) # prime the pump -- load classes etc. + n := 1 + t2 := &time + + repeat { + n *:= 10 + t1 := t2 + proc(n) # call proc n times + t2 := &time # get ending time + dt := integer(t2 - t1) + if dt >= looptime / 20 then # if close enough to estimate + break + } + + n := integer(1.1 * n * looptime / real(dt)) # calc final loop count + collect() # clean up accumulated garbage + + t1 := &time + until t1 ~=:= &time # await next tick + proc(n) # run timing loop for real + t2 := &time # calculate elapsed time + dt := integer(t2 - t1) + + t1 := dt / real(n) + nsec := integer(t1 * 1000000 + 0.5) + return nsec +end + + + +####################### microbenchmark procedures ##################### + + + +procedure nothing(n) + if /n then return "nothing" + every 1 to n do + 0 +end + + + +procedure uplus(n) + if /n then return "+407" + every 1 to n do + +407 +end + +procedure uplusr(n) + if /n then return "+7.25" + every 1 to n do + +7.25 +end + +procedure absf(n) + if /n then return "abs(-3)" + every 1 to n do + abs(-3) +end + +procedure intadd(n) + if /n then return "4 + 7" + every 1 to n do + 4 + 7 +end + +procedure intcmp(n) + if /n then return "4 < 7" + every 1 to n do + 4 < 7 +end + +procedure intpow(n) + if /n then return "4 ^ 7" + every 1 to n do + 4 ^ 7 +end + +procedure realcmp(n) + if /n then return "1.6 < 2.7" + every 1 to n do + 1.6 < 2.7 +end + +procedure cosf(n) + if /n then return "cos(0.2)" + every 1 to n do + cos(0.2) +end + +procedure sqrtf(n) + if /n then return "sqrt(7.4)" + every 1 to n do + sqrt(7.4) +end + +procedure logf(n) + if /n then return "log(25.,17.)" + every 1 to n do + log(25.,17.) +end + + + + + + +procedure nullfunc(n) + if /n then return "p()" + every 1 to n do + nullf() +end + + procedure nullf() + end + +procedure listcall(n) + static L + initial L := [] + if /n then return "p ! L" + every 1 to n do + nullf ! L +end + +procedure addfunc(n) + if /n then return "add(4, 7)" + every 1 to n do + add(4, 7) +end + procedure add(a, b) + return a + b + end + + +procedure rfact0(n) + if /n then return "rfact(0)" + every 1 to n do + rfact(0) +end + +procedure rfact10(n) + if /n then return "rfact(10)" + every 1 to n do + rfact(10) +end + +procedure rfact(n) # makes n recursive calls + if n < 1 then return 1 + else return n * rfact(n - 1) +end + + +procedure rfib5(n) + if /n then return "rfib(5)" + every 1 to n do + rfib(5) +end + +procedure rfib(n) # slow, recursive Fibonacci + if n < 3 then + return 1 + else + return rfib(n - 2) + rfib(n - 1) +end + + +procedure prslow(n) # slow prime number counting + local i, k + if /n then return "prslow(7)" + every 1 to n do { + k := 0 + every i := 2 to 7 do { + if i % (2 to i - 1) = 0 then + next + k +:= 1 + } + } +end + + +procedure if0(n) + if /n then return "if 0 then 1" + every 1 to n do + if 0 then 1 +end + +procedure case3(n) + if /n then return "case 3 of..." + every 1 to n do + case 3 of { + 1 : 1 + 2 : 2 + 3 : 3 + 4 : 4 + default : 0 + } +end + +procedure nulltest(n) + if /n then return "\\8" + every 1 to n do + \8 +end + +procedure typef(n) + if /n then return "type(s)" + every 1 to n do + type("abcde") +end + +procedure imagef(n) + if /n then return "image(s)" + every 1 to n do + image("ab\tcd") +end + + +procedure marshal(n) + if /n then return "2(3,1,4,1,6)" + every 1 to n do + 2 (3, 1, 4, 1, 6) +end + + +procedure conj5(n) + if /n then return "1&2&3&4&5" + every 1 to n do + 1 & 2 & 3 & 4 & 5 +end + +procedure everyalt(n) + if /n then return "1|2|3|4|5" + every 1 to n do + every 1 | 2 | 3 | 4 | 5 +end + +procedure everyto(n) + if /n then return "1 to 5" + every 1 to n do + every 1 to 5 +end + +procedure evsusp(n) + if /n then return "suspend i" + every susproc(n) +end + procedure susproc(n) + suspend 1 to n + end + + +procedure intcoerce(n) + if /n then return "+\"407\"" + every 1 to n do + +"407" +end + +procedure realcoerce(n) + if /n then return "+\"7.25\"" + every 1 to n do + +"7.25" +end + +procedure strcoerce(n) + if /n then return "*407" + every 1 to n do + *407 +end + +procedure strcoercer(n) + if /n then return "*7.25" + every 1 to n do + *7.25 +end + + + +procedure tointeger(n) + if /n then return "integer(\"407\")" + every 1 to n do + integer("407") +end + +procedure toreal(n) + if /n then return "real(\"7.25\")" + every 1 to n do + real("407") +end + +procedure tostring(n) + if /n then return "string(407)" + every 1 to n do + string(407) +end + +procedure rtostring(n) + if /n then return "string(7.25)" + every 1 to n do + string(7.25) +end + +procedure tocset(n) + if /n then return "cset(\"407\")" + every 1 to n do + cset("407") +end + + + +procedure charf(n) + if /n then return "char(65)" + every 1 to n do + char(65) +end + +procedure ordf(n) + if /n then return "ord(\"A\")" + every 1 to n do + ord("A") +end + +procedure strsize(n) + if /n then return "*\"abcde\"" + every 1 to n do + *"abcde" +end + +procedure concat(n) + if /n then return "\"a\" || \"b\"" + every 1 to n do + "a" || "b" +end + +procedure strpick(n) + if /n then return "?\"abcde\"" + every 1 to n do + ?"abcde" +end + +procedure strbang(n) + if /n then return "!\"12345\"" + every 1 to n do + every !"12345" +end + +procedure strsub(n) + if /n then return "\"abcde\"[3]" + every 1 to n do + "abcde"[3] +end + +procedure substr(n) + if /n then return "\"abcde\"[2:5]" + every 1 to n do + "abcde"[2:5] +end + +procedure subsasg(n) + local s + if /n then return "s[2:5] := \"x\"" + every 1 to n do + (s := "abcde")[2:5] := "x" +end + +procedure strcmp(n) + if /n then return "\"abc\">>\"aaa\"" + every 1 to n do + "abc" >> "aaa" +end + +procedure strident(n) + if /n then return "\"abc\"===\"aaa\"" + every 1 to n do + "abc" === "aaa" +end + +procedure replf(n) + if /n then return "repl(\"-\",20)" + every 1 to n do + repl("-", 20) +end + +procedure reversef(n) + if /n then return "reverse(\"a...z\")" + every 1 to n do + reverse("abcdefghijklmnopqrstuvwxyz") +end + +procedure leftf(n) + if /n then return "left(\"a\",10)" + every 1 to n do + left("a",10) +end + +procedure centerf(n) + if /n then return "center(\"a\",10)" + every 1 to n do + center("a",10) +end + +procedure rightf(n) + if /n then return "right(\"a\",10)" + every 1 to n do + right("a",10) +end + +procedure trimf(n) + if /n then return "trim(\"a ...\")" + every 1 to n do + trim("a ") +end + +procedure entabf(n) + if /n then return "entab(\"a ...\")" + every 1 to n do + entab("a ") +end + +procedure detabf(n) + if /n then return "detab(\"a\\tb\\tc\")" + every 1 to n do + detab("a\tb\tc") +end + +procedure mapf(n) + if /n then return "map(s1,s2,s3)" + every 1 to n do + map("abcde", "bcdef", "cdefg") +end + + +procedure nullscan(n) + if /n then return "s ? 0" + every 1 to n do + "abc" ? 0 +end + +procedure movef(n) + if /n then return "move(0)" + "abcde" ? every 1 to n do + move(0) +end + +procedure tabf(n) + if /n then return "tab(3)" + "abcde" ? every 1 to n do + tab(3) +end + +procedure matchf(n) + if /n then return "match(\"abc\")" + "abcde" ? every 1 to n do + match("abc") +end + +procedure tabmat(n) + if /n then return "s1 ? =s2" + "abcde" ? every 1 to n do + ="abd" +end + +procedure posf(n) + if /n then return "pos(-1)" + "abcde" ? every 1 to n do + pos(-1) +end + +procedure anyf(n) + if /n then return "any('aeiou')" + "abcde" ? every 1 to n do + any('aeiou') +end + +procedure manyf(n) + if /n then return "many(&lcase)" + "abcde" ? every 1 to n do + many(&lcase) +end + +procedure uptof(n) + if /n then return "upto('d')" + "abcde" ? every 1 to n do + upto('d') +end + +procedure findf(n) + if /n then return "find(\"de\")" + "abcde" ? every 1 to n do + find("de") +end + +procedure balf(n) + if /n then return "bal('+')" + "(a*b)+(c/d)" ? every 1 to n do + upto('+') +end + + +procedure cssize(n) + if /n then return "*&digits" + every 1 to n do + *&digits +end + +procedure cscompl(n) + if /n then return "~&digits" + every 1 to n do + ~&digits +end + + + +procedure lcreate(n) + if /n then return "list(5,0)" + every 1 to n do + list(5,0) +end + +procedure lconst(n) + local x + if /n then return "[1,2,3,4,5]" + every 1 to n do + x := [1,2,3,4,5] # must store, else jcont suppresses +end + +procedure lcopy(n) + static L + initial L := [1,2,3,4,5] + if /n then return "copy(L)" + every 1 to n do + copy(L) +end + +procedure lsort(n) + static L + initial L := [2,7,1,8,3] + if /n then return "sort(L)" + every 1 to n do + sort(L) +end + +procedure lsize(n) + static L + initial L := [1,2,3,4,5] + if /n then return "*L" + every 1 to n do + *L +end + +procedure lpick(n) + static L + initial L := [1,2,3,4,5] + if /n then return "?L" + every 1 to n do + ?L +end + +procedure lsubscr(n) + static L + initial L := [1,2,3,4,5] + if /n then return "L[3]" + every 1 to n do + L[3] +end + +procedure lbang(n) + static L + initial L := [1,2,3,4,5] + if /n then return "!L" + every 1 to n do + every !L +end + +procedure putget(n) + static L + initial L := [] + if /n then return "get(put(L,0))" + every 1 to n do + get(put(L,0)) +end + +procedure pushpop(n) + static L + initial L := [] + if /n then return "pop(push(L,0))" + every 1 to n do + pop(push(L,0)) +end + +procedure putget12(n) + static L + initial L := [3,1,4,1,5,9,2,6,5,3,5,8] + if /n then return "get(put(L12,0))" + every 1 to n do + get(put(L,0)) +end + +procedure pushpop12(n) + static L + initial L := [3,1,4,1,5,9,2,6,5,3,5,8] + if /n then return "pop(push(L12,0))" + every 1 to n do + pop(push(L,0)) +end + + + +procedure setcreate(n) + if /n then return "set()" + every 1 to n do + set() +end + +procedure setcopy(n) + static S + initial insert(S := set(), 5) + if /n then return "copy(S)" + every 1 to n do + copy(S) +end + +procedure setinsert(n) + static S + initial insert(S := set(), 5) + if /n then return "insert(S,5)" + every 1 to n do + insert(S,5) +end + +procedure setmember(n) + static S + initial insert(S := set(), 5) + if /n then return "member(S,5)" + every 1 to n do + member(S,5) +end + +procedure setinsdel(n) + static S + initial S := set() + if /n then return "insert+delete" + every 1 to n do + delete(insert(S,5),5) +end + +procedure setpick(n) + static S + initial insert(S := set(), 5) + if /n then return "?S" + every 1 to n do + ?S +end + +procedure setbang(n) + static S + initial every insert(S := set(), 1 to 5) + if /n then return "!S" + every 1 to n do + every !S +end + + + +procedure tblcreate(n) + if /n then return "table()" + every 1 to n do + table() +end + +procedure tblasgn(n) + static T + initial (T := table())[5] := 1 + if /n then return "T[5] := 1" + every 1 to n do + T[5] := 1 +end + +procedure tblsub(n) + static T + initial (T := table())[5] := 1 + if /n then return "T[5]" + every 1 to n do + T[5] +end + + + +record point(x,y) +record bigrec(alpha, beta, gamma, delta, epsilon, figaro, guido, horatio) + +procedure recconstr(n) + if /n then return "record(4,7)" + every 1 to n do + point(4,7) +end + +procedure reccopy(n) + static R + initial R := point(4,7) + if /n then return "copy(R)" + every 1 to n do + copy(R) +end + +procedure recfield(n) + static R + initial R := point(4,7) + if /n then return "R.f" + every 1 to n do + R.y +end + +procedure bigfield(n) + static R + initial R := bigrec() + if /n then return "R2.f" + every 1 to n do + R.horatio +end + + + +global ggg + +procedure globasgn(n) + if /n then return "global := 1" + every 1 to n do + ggg := 1 +end + +procedure loclasgn(n) + local i + if /n then return "local := 1" + every 1 to n do + i := 1 +end + +procedure statasgn(n) + static i + if /n then return "static := 1" + every 1 to n do + i := 1 +end + + + +procedure readz(n) + static f + initial f := open("/dev/zero","ru") + if /n then return "reads(zero,8)" + every 1 to n do + reads(f, 8) +end + +procedure writecon(n) + if /n then return "write(\"a...z\")" + every 1 to n do + write(sink, "abcdefghijklmnopqrstuvwxyz") +end + +procedure writestr(n) + static s + initial s := "abcdefghijklmnopqrstuvwxyz" + if /n then return "write(s)" + every 1 to n do + write(sink, s) +end + + +procedure cxcreate(n) + if /n then return "create |\"a\"" + every 1 to n do + create |"a" +end + +procedure cxget(n) + static C + initial C := create |"a" + if /n then return "@C" + every 1 to n do + @C +end + diff --git a/tests/bench/micsum.icn b/tests/bench/micsum.icn new file mode 100644 index 0000000..75bd8b6 --- /dev/null +++ b/tests/bench/micsum.icn @@ -0,0 +1,76 @@ +# micsum.icn -- summarize micro.icn outputs +# +# 24-dec-09/gmt +# +# usage: icon micsum.icn file... +# +# Reads one or more output files created by micro.icn and summarizes the +# contents. Overhead and "nothing" lines are treated specially. Remaining +# lines are considered true microbenchmarks. Output columns are: +# +# N number of microbenchmarks +# ovhead overhead measurement +# rmserr RMS average error from "nothing" lines +# median median microbenchmark time +# gmean geometric mean of microbenchmark times + + +procedure main(args) + local a, f + + write(" N ovhead rmserr median gmean filename") + if *args = 0 then + dofile(&input, "stdin") + else while a := get(args) do { + f := open(a) | stop("cannot open ", a) + dofile(f, a) + } +end + +procedure dofile(f, name) + local line, label, overhead, nothings, others, n, t, v + nothings := [] + others := [] + + while line := read(f) do line ? { + tab(many(' ')) + n := integer(tab(many('-0123456789'))) + tab(many(' ')) + label := tab(0) + if label == "overhead" then + overhead := n + else if label == "nothing" then + put(nothings, n) + else + put(others, n) + } + + # count of measurements + writes(*others) + + # overhead value + writes(right(overhead, 7)) + + # RMS error ("nothing" values) + t := 0 + every t +:= !nothings ^ 2 + t := integer(sqrt(t / *nothings) + 0.5) + writes(right(t, 7)) + + # median of other values + others := sort(others) + t := others[*others / 2 + 1] + writes(right(t, 7)) + + # geometric mean of other values + t := 0.0 + every v := !others do + t +:= (if v <= 0 then 0 else log(v)) + t := integer(&e ^ (t / *others) + 0.5) + writes(right(t, 7)) + + # file name + write(" ", name) + return + +end diff --git a/tests/bench/rsg.dat b/tests/bench/rsg.dat index 9b49b74..9b49b74 100755..100644 --- a/tests/bench/rsg.dat +++ b/tests/bench/rsg.dat diff --git a/tests/general/Makefile b/tests/general/Makefile index 56da471..78a4908 100644 --- a/tests/general/Makefile +++ b/tests/general/Makefile @@ -13,17 +13,10 @@ Test Test-icont: Test-programs Test-preproc Test-options # test programs Programs Programs-icont Test-programs: - IC=icont sh Test-icon + sh Test-icon Samples Samples-icont: - IC=icont sh Test-icon $(SAMPLES) - - -Test-iconc: - IC=iconc sh Test-icon - -Samples-iconc: - IC=iconc sh Test-icon $(SAMPLES) + sh Test-icon $(SAMPLES) # test preprocessor @@ -43,6 +36,15 @@ Test-options: : options test passed +# test garbage collection by forcing small region sizes +# (note: gc2 and kwds will fail) + +Test-tiny: + sh Test-icon 1000 1000 + + +# clean up + Clean: -rm -f *.u? *.c *.h foo.baz tmp1 tmp2 *.out *.err *.all -rm -f xx `find * -type f -perm -100 ! -name 'Test-*' -print` diff --git a/tests/general/Test-icon b/tests/general/Test-icon index 07ccb87..9c3b265 100755 --- a/tests/general/Test-icon +++ b/tests/general/Test-icon @@ -1,36 +1,37 @@ #!/bin/sh # -# Test-icont -- test the Icon translator and interpreter. +# Test-icon -- test the Icon translator and interpreter. # -# usage: Test-icont [file...] -# -# If $IC is set to iconc, the compiler will be used instead. +# usage: Test-icon [BLKSIZE [STRSIZE]] [file...] -IC=${IC-icont} -IC=../../bin/$IC +IC=../../bin/icont ICONX=../../bin/iconx unset IPATH LPATH FPATH unset BLKSIZE STRSIZE MSTKSIZE COEXPSIZE QLSIZE -# may be needed with Icon is built with BinaryHeader defined +# may be needed if Icon is built with BinaryHeader defined export ICONX +# check for BKLSIZE / STRSIZE arguments +case X$1 in + X[0-9]*) export BLKSIZE=$1; echo BLKSIZE=$1; shift;; +esac +case X$1 in + X[0-9]*) export STRSIZE=$1; echo STRSIZE=$1; shift;; +esac + # echo system environment echo "" uname -a # check that we have what we need -case $IC in - *icont) - ls ../../bin/icont ../../bin/iconx >/dev/null || exit 0 - echo "icont: `$IC -V 2>&1`" - echo "iconx: `$ICONX -V 2>&1`" - ;; - *iconc) - ls -l ../../bin/iconc ../../bin/rt.* || exit 0 - ;; -esac +ls ../../bin/icont ../../bin/iconx >/dev/null || exit 0 +echo "icont: `$IC -V 2>&1`" +echo "iconx: `$ICONX -V 2>&1`" + +# report enabled features +$IC -s features.icn -x # if no test files specified, run them all if [ $# = 0 ]; then diff --git a/tests/general/cfuncs.icn b/tests/general/cfuncs.icn index 40af8fe..4a1c856 100644 --- a/tests/general/cfuncs.icn +++ b/tests/general/cfuncs.icn @@ -1,33 +1,21 @@ -# A simple test of a few standard C functions -# for Unix platforms that implement loadfunc(). +# Test dynamic loading with a few standard cfuncs. -$ifdef _DYNAMIC_LOADING +link cfunc - link cfunc +procedure main() + local i - procedure main() - local i + every i := 500 to 513 do + gen(bitcount, i) - every i := 500 to 513 do - gen(bitcount, i) - gen(vword, 314159) - gen(lgconv, 10^30) - gen(unpack, "abcd") - gen(pack, 1684234849) - end + write() + gen(vword, 314159) + gen(lgconv, 10 ^ 30) + gen(unpack, "abcd") + gen(pack, 1684234849) +end - procedure gen(p, a) - write(image(p), "(", image(a), ") = ", p(a) | "[failed]") - return - end - -$else - - # fake the "passing" output when LoadFunc is not available, - # so that "make Tests" does not fail. - - procedure main() - every write(!open("cfuncs.std")) - end - -$endif +procedure gen(p, a) + write(image(p), "(", image(a), ") = ", p(a) | "[failed]") + return +end diff --git a/tests/general/cfuncs.std b/tests/general/cfuncs.std index de20183..6023894 100644 --- a/tests/general/cfuncs.std +++ b/tests/general/cfuncs.std @@ -12,6 +12,7 @@ function bitcount(510) = 8 function bitcount(511) = 9 function bitcount(512) = 1 function bitcount(513) = 2 + procedure vword(314159) = 314159 procedure lgconv(integer(~10^30)) = 1000000000000000000000000000000 procedure unpack("abcd") = 1684234849 diff --git a/tests/general/checkfpx.icn b/tests/general/checkfpx.icn deleted file mode 100644 index 947c4fe..0000000 --- a/tests/general/checkfpx.icn +++ /dev/null @@ -1,127 +0,0 @@ -procedure main() - write("This test of floating-point arithmetic is likely to show") - write("differences from platform to platform because of differences") - write("in floating-point precision and details of the routines that") - write("convert floating-point numbers to strings. If the values") - write("produced in local tests are approximately the same in magnitude") - write("as shown in the standard results, there's nothing to worry about.") - write("In addition, some platforms may show 0.0 as \"-0.0\". You can") - write("ignore this if you wish.") - p1() - p2() - p3() -end - -procedure p1() - write("every 1 to 10 do write(?0) ----> ",(every 1 to 10 do write(Image(?0))) | "none") - write("every i := 1 to 50 do write(real(repl(\"0\",i) || \"2.\")) ----> ",Image(every i := 1 to 50 do write(real(repl("0",i) || "2."))) | "none") - write("every i := 1 to 30 do write(integer(repl(\"0\",i) || \"2\")) ----> ",Image(every i := 1 to 30 do write(integer(repl("0",i) || "2"))) | "none") - write("2.0 ~=== +2.0 ----> ",Image(2.0 ~=== +2.0) | "none") - write("abs(3.0) ----> ",Image(abs(3.0)) | "none") - write("Image(2e13) ----> ",Image(Image(2e13)) | "none") - write("Image(0.0006) ----> ",Image(Image(0.0006)) | "none") - write("Image(2.0) ----> ",Image(Image(2.0)) | "none") - write("integer(2.0) ----> ",Image(integer(2.0)) | "none") - write("integer(2.7) ----> ",Image(integer(2.7)) | "none") - write("integer(\".\") ----> ",Image(integer(".")) | "none") - write("integer(\".3\") ----> ",Image(integer(".3")) | "none") - write("integer(\"0.3\") ----> ",Image(integer("0.3")) | "none") - write("integer(\" . 3\") ----> ",Image(integer(" . 3")) | "none") - write("integer(\"e2\") ----> ",Image(integer("e2")) | "none") - write("integer(\"3e500\") ----> ",Image(integer("3e500")) | "none") - write("numeric(2.0) ----> ",Image(numeric(2.0)) | "none") - write("numeric(2.7) ----> ",Image(numeric(2.7)) | "none") - write("numeric(\".\") ----> ",Image(numeric(".")) | "none") - write("numeric(\".3\") ----> ",Image(numeric(".3")) | "none") - write("numeric(\"0.3\") ----> ",Image(numeric("0.3")) | "none") -end - -procedure p2() - write("numeric(\" . 3\") ----> ",Image(numeric(" . 3")) | "none") - write("numeric(\"e2\") ----> ",Image(numeric("e2")) | "none") - write("numeric(\"3e500\") ----> ",Image(numeric("3e500")) | "none") - write("real(2) ----> ",Image(real(2)) | "none") - write("real(2.0) ----> ",Image(real(2.0)) | "none") - write("real(2.7) ----> ",Image(real(2.7)) | "none") - write("real(\"2\") ----> ",Image(real("2")) | "none") - write("real(\" 2\") ----> ",Image(real(" 2")) | "none") - write("real(\"2 \") ----> ",Image(real("2 ")) | "none") - write("real(\"+2\") ----> ",Image(real("+2")) | "none") - write("real(\"-2\") ----> ",Image(real("-2")) | "none") - write("real(\"- 2\") ----> ",Image(real("- 2")) | "none") - write("real(\" - 2 \") ----> ",Image(real(" - 2 ")) | "none") - write("real(\"\") ----> ",Image(real("")) | "none") - write("real(\"--2\") ----> ",Image(real("--2")) | "none") - write("real(\" \") ----> ",Image(real(" ")) | "none") - write("real(\"-\") ----> ",Image(real("-")) | "none") - write("real(\"+\") ----> ",Image(real("+")) | "none") - write("real(\".\") ----> ",Image(real(".")) | "none") - write("real(\".3\") ----> ",Image(real(".3")) | "none") - write("real(\"0.3\") ----> ",Image(real("0.3")) | "none") - write("real(\" . 3\") ----> ",Image(real(" . 3")) | "none") - write("real(\"e2\") ----> ",Image(real("e2")) | "none") - write("real(\"3e500\") ----> ",Image(real("3e500")) | "none") - write("real(\"7r4\") ----> ",Image(real("7r4")) | "none") - write("real(\"4r7\") ----> ",Image(real("4r7")) | "none") - write("real(\"4r 7\") ----> ",Image(real("4r 7")) | "none") - write("real(\"7r 4\") ----> ",Image(real("7r 4")) | "none") - write("real(\"16rff\") ----> ",Image(real("16rff")) | "none") - write("real(\"36rcat\") ----> ",Image(real("36rcat")) | "none") - write("real(\"36Rcat\") ----> ",Image(real("36Rcat")) | "none") - write("real(\"36rCAT\") ----> ",Image(real("36rCAT")) | "none") - write("real(\"1r1\") ----> ",Image(real("1r1")) | "none") - write("real(\"2r0\") ----> ",Image(real("2r0")) | "none") - write("real(\"22222222222222222222222222222\") ----> ",Image(real("22222222222222222222222222222")) | "none") - write("numeric(2.0) ----> ",Image(numeric(2.0)) | "none") - write("numeric(2.7) ----> ",Image(numeric(2.7)) | "none") - write("numeric(0.3) ----> ",Image(numeric(0.3)) | "none") - write("numeric(e2) ----> ",Image(numeric(e2)) | "none") - write("36. ^ 9 ----> ",Image(36. ^ 9) | "none") - write("36 ^ 9. ----> ",Image(36 ^ 9.) | "none") - write("36. ^ 9. ----> ",Image(36. ^ 9.) | "none") - write("-36. ^ 9 ----> ",Image(-36. ^ 9) | "none") - write("-36. ^ -9 ----> ",Image(-36. ^ -9) | "none") - write((every i := 1 to 37 do write(Image(real(repl("2",i) || ".")))) | "failed") - write((every i := 1 to 37 do write(Image(real(repl("2",i) || ".2")))) | "failed") - write((every i := 1 to 37 do write(Image((repl("2",i) || ".2") + 1))) | "failed") - write("2.0 === +2.0 ----> ",Image(2.0 === +2.0) | "none") - write("?30.0 ----> ",Image(?30.0) | "none") -end - -procedure p3() - write("copy(1.0) ----> ",Image(copy(1.0)) | "none") - write("trim(3.14159,58) ----> ",Image(trim(3.14159,58)) | "none") - write("Image(2e13) ----> ",Image(Image(2e13)) | "none") - write("Image(0.0006) ----> ",Image(Image(0.0006)) | "none") -end -procedure Image(x) - local head, tail, exp, span - - span := 9 - - if type(x) ~== "real" then return image(x) - else { - x ? { - if head := tab(upto('e')) - then { - tail := tab(0) - head ? return (tab(span | 0) || tail) - } - else { - head := tab(span - 1 | 0) - # - # if head is too small to include the ".", go to floating point - # format. - # - if exp := *tab(upto('.')) then - head ? return move(1) || "." || move(span - 3) || - "e+" || (span - 3 + exp) - else { - if head[-1] == "." then - head ||:= (move(1) | "0") - return head - } - } - } - } -end diff --git a/tests/general/checkfpx.std b/tests/general/checkfpx.std deleted file mode 100644 index 481dce3..0000000 --- a/tests/general/checkfpx.std +++ /dev/null @@ -1,283 +0,0 @@ -This test of floating-point arithmetic is likely to show -differences from platform to platform because of differences -in floating-point precision and details of the routines that -convert floating-point numbers to strings. If the values -produced in local tests are approximately the same in magnitude -as shown in the standard results, there's nothing to worry about. -In addition, some platforms may show 0.0 as "-0.0". You can -ignore this if you wish. -0.21132 -0.41242 -0.31579 -0.51044 -0.42173 -0.30569 -0.07960 -0.73752 -0.05072 -0.71694 -every 1 to 10 do write(?0) ----> none -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -2.0 -every i := 1 to 50 do write(real(repl("0",i) || "2.")) ----> none -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -2 -every i := 1 to 30 do write(integer(repl("0",i) || "2")) ----> none -2.0 ~=== +2.0 ----> none -abs(3.0) ----> 3.0 -Image(2e13) ----> "2e+13" -Image(0.0006) ----> "0.0006" -Image(2.0) ----> "2.0" -integer(2.0) ----> 2 -integer(2.7) ----> 2 -integer(".") ----> none -integer(".3") ----> 0 -integer("0.3") ----> 0 -integer(" . 3") ----> none -integer("e2") ----> none -integer("3e500") ----> none -numeric(2.0) ----> 2.0 -numeric(2.7) ----> 2.7 -numeric(".") ----> none -numeric(".3") ----> 0.3 -numeric("0.3") ----> 0.3 -numeric(" . 3") ----> none -numeric("e2") ----> none -numeric("3e500") ----> none -real(2) ----> 2.0 -real(2.0) ----> 2.0 -real(2.7) ----> 2.7 -real("2") ----> 2.0 -real(" 2") ----> 2.0 -real("2 ") ----> 2.0 -real("+2") ----> 2.0 -real("-2") ----> -2.0 -real("- 2") ----> none -real(" - 2 ") ----> none -real("") ----> none -real("--2") ----> none -real(" ") ----> none -real("-") ----> none -real("+") ----> none -real(".") ----> none -real(".3") ----> 0.3 -real("0.3") ----> 0.3 -real(" . 3") ----> none -real("e2") ----> none -real("3e500") ----> none -real("7r4") ----> 4.0 -real("4r7") ----> none -real("4r 7") ----> none -real("7r 4") ----> none -real("16rff") ----> 255.0 -real("36rcat") ----> 15941.0 -real("36Rcat") ----> 15941.0 -real("36rCAT") ----> 15941.0 -real("1r1") ----> none -real("2r0") ----> 0.0 -real("22222222222222222222222222222") ----> 2.222222e+28 -numeric(2.0) ----> 2.0 -numeric(2.7) ----> 2.7 -numeric(0.3) ----> 0.3 -numeric(e2) ----> none -36. ^ 9 ----> 1.015599e+14 -36 ^ 9. ----> 1.015599e+14 -36. ^ 9. ----> 1.015599e+14 --36. ^ 9 ----> -1.01559e+14 --36. ^ -9 ----> -9.84640e-15 -2.0 -22.0 -222.0 -2222.0 -22222.0 -222222.0 -2.222222e+6 -2.222222e+7 -2.222222e+8 -2.222222e+9 -2.222222e+10 -2.222222e+11 -2.222222e+12 -2.222222e+13 -2.222222e+14 -2.222222e+15 -2.222222e+16 -2.222222e+17 -2.222222e+18 -2.222222e+19 -2.222222e+20 -2.222222e+21 -2.222222e+22 -2.222222e+23 -2.222222e+24 -2.222222e+25 -2.222222e+26 -2.222222e+27 -2.222222e+28 -2.222222e+29 -2.222222e+30 -2.222222e+31 -2.222222e+32 -2.222222e+33 -2.222222e+34 -2.222222e+35 -2.222222e+36 -failed -2.2 -22.2 -222.2 -2222.2 -22222.2 -222222.2 -2.222222e+6 -2.222222e+7 -2.222222e+8 -2.222222e+9 -2.222222e+10 -2.222222e+11 -2.222222e+12 -2.222222e+13 -2.222222e+14 -2.222222e+15 -2.222222e+16 -2.222222e+17 -2.222222e+18 -2.222222e+19 -2.222222e+20 -2.222222e+21 -2.222222e+22 -2.222222e+23 -2.222222e+24 -2.222222e+25 -2.222222e+26 -2.222222e+27 -2.222222e+28 -2.222222e+29 -2.222222e+30 -2.222222e+31 -2.222222e+32 -2.222222e+33 -2.222222e+34 -2.222222e+35 -2.222222e+36 -failed -3.2 -23.2 -223.2 -2223.2 -22223.2 -222223.2 -2.222223e+6 -2.222222e+7 -2.222222e+8 -2.222222e+9 -2.222222e+10 -2.222222e+11 -2.222222e+12 -2.222222e+13 -2.222222e+14 -2.222222e+15 -2.222222e+16 -2.222222e+17 -2.222222e+18 -2.222222e+19 -2.222222e+20 -2.222222e+21 -2.222222e+22 -2.222222e+23 -2.222222e+24 -2.222222e+25 -2.222222e+26 -2.222222e+27 -2.222222e+28 -2.222222e+29 -2.222222e+30 -2.222222e+31 -2.222222e+32 -2.222222e+33 -2.222222e+34 -2.222222e+35 -2.222222e+36 -failed -2.0 === +2.0 ----> 2.0 -?30.0 ----> 5 -copy(1.0) ----> 1.0 -trim(3.14159,58) ----> "3.14159" -Image(2e13) ----> "2e+13" -Image(0.0006) ----> "0.0006" diff --git a/tests/general/checkx.icn b/tests/general/checkx.icn deleted file mode 100644 index c1a8623..0000000 --- a/tests/general/checkx.icn +++ /dev/null @@ -1,182 +0,0 @@ -record array(a,b,c,d,e,f,g) - -procedure dummy(u,v,x,y,z) - suspend u | v - return x -end - -procedure main() - p1() - p2() - p3() - p4() - p5() - p6() - p7() - p8() - p9() -end - -procedure p1() - write("image(2) ----> ",image(image(2)) | "none") - write("image('cab') ----> ",image(image('cab')) | "none") - write("image(&lcase) ----> ",image(image(&lcase)) | "none") - write("image('abcdefghijklmnopqrstuvwxyz') ----> ",image(image('abcdefghijklmnopqrstuvwxyz')) | "none") - write("image(&input) ----> ",image(image(&input)) | "none") - write("image() ----> ",image(image()) | "none") - write("image(&null) ----> ",image(image(&null)) | "none") - write("image([1,2,3]) ----> ",image(image([1,2,3])) | "none") - write("image([]) ----> ",image(image([])) | "none") - write("image([,]) ----> ",image(image([,])) | "none") - write("image(table()) ----> ",image(image(table())) | "none") - write("image(table(3)) ----> ",image(image(table(3))) | "none") - write("image(list(0)) ----> ",image(image(list(0))) | "none") - write("image(repl) ----> ",image(image(repl)) | "none") - write("image(main) ----> ",image(image(main)) | "none") - write("image(repl(&lcase,10)) ----> ",image(image(repl(&lcase,10))) | "none") - write("image(array) ----> ",image(image(array)) | "none") - write("image(a) ----> ",image(image(a)) | "none") - write("image(array) ----> ",image(image(array)) | "none") - write("image(image) ----> ",image(image(image)) | "none") -end - -procedure p2() - write("integer(2) ----> ",image(integer(2)) | "none") - write("integer(\"2\") ----> ",image(integer("2")) | "none") - write("integer(\" 2\") ----> ",image(integer(" 2")) | "none") - write("integer(\"2 \") ----> ",image(integer("2 ")) | "none") - write("integer(\"+2\") ----> ",image(integer("+2")) | "none") - write("integer(\"-2\") ----> ",image(integer("-2")) | "none") - write("integer(\"- 2\") ----> ",image(integer("- 2")) | "none") - write("integer(\" - 2 \") ----> ",image(integer(" - 2 ")) | "none") - write("integer(\"\") ----> ",image(integer("")) | "none") - write("integer(\"--2\") ----> ",image(integer("--2")) | "none") - write("integer(\" \") ----> ",image(integer(" ")) | "none") - write("integer(\"-\") ----> ",image(integer("-")) | "none") - write("integer(\"+\") ----> ",image(integer("+")) | "none") - write("integer(\"7r4\") ----> ",image(integer("7r4")) | "none") - write("integer(\"4r7\") ----> ",image(integer("4r7")) | "none") - write("integer(\"4r 7\") ----> ",image(integer("4r 7")) | "none") - write("integer(\"7r 4\") ----> ",image(integer("7r 4")) | "none") - write("integer(\"16rff\") ----> ",image(integer("16rff")) | "none") - write("integer(\"36rcat\") ----> ",image(integer("36rcat")) | "none") - write("integer(\"36Rcat\") ----> ",image(integer("36Rcat")) | "none") - write("integer(\"36rCAT\") ----> ",image(integer("36rCAT")) | "none") - write("integer(\"1r1\") ----> ",image(integer("1r1")) | "none") - write("integer(\"2r0\") ----> ",image(integer("2r0")) | "none") - write("integer(integer) ----> ",image(integer(integer)) | "none") - write("integer := abs ----> ",image(integer := abs) | "none") -end - -procedure p3() - write("numeric(2) ----> ",image(numeric(2)) | "none") - write("numeric(\"2\") ----> ",image(numeric("2")) | "none") - write("numeric(\" 2\") ----> ",image(numeric(" 2")) | "none") - write("numeric(\"2 \") ----> ",image(numeric("2 ")) | "none") - write("numeric(\"+2\") ----> ",image(numeric("+2")) | "none") - write("numeric(\"-2\") ----> ",image(numeric("-2")) | "none") - write("numeric(\"- 2\") ----> ",image(numeric("- 2")) | "none") - write("numeric(\" - 2 \") ----> ",image(numeric(" - 2 ")) | "none") - write("numeric(\"\") ----> ",image(numeric("")) | "none") - write("numeric(\"--2\") ----> ",image(numeric("--2")) | "none") - write("numeric(\" \") ----> ",image(numeric(" ")) | "none") - write("numeric(\"-\") ----> ",image(numeric("-")) | "none") - write("numeric(\"+\") ----> ",image(numeric("+")) | "none") - write("numeric(\"7r4\") ----> ",image(numeric("7r4")) | "none") - write("numeric(\"4r7\") ----> ",image(numeric("4r7")) | "none") - write("numeric(\"4r 7\") ----> ",image(numeric("4r 7")) | "none") - write("numeric(\"7r 4\") ----> ",image(numeric("7r 4")) | "none") - write("numeric(\"16rff\") ----> ",image(numeric("16rff")) | "none") - write("numeric(\"36rcat\") ----> ",image(numeric("36rcat")) | "none") - write("numeric(\"36Rcat\") ----> ",image(numeric("36Rcat")) | "none") - write("numeric(\"36rCAT\") ----> ",image(numeric("36rCAT")) | "none") - write("numeric(\"1r1\") ----> ",image(numeric("1r1")) | "none") - write("numeric(\"2r0\") ----> ",image(numeric("2r0")) | "none") -end - -procedure p4() -end - -procedure p5() - write("numeric(2) ----> ",image(numeric(2)) | "none") - write("numeric(2) ----> ",image(numeric(2)) | "none") - write("numeric(+2) ----> ",image(numeric(+2)) | "none") - write("numeric(-2) ----> ",image(numeric(-2)) | "none") - write("numeric() ----> ",image(numeric()) | "none") - write("numeric(7r4) ----> ",image(numeric(7r4)) | "none") - write("numeric(16rff) ----> ",image(numeric(16rff)) | "none") - write("numeric(36rcat) ----> ",image(numeric(36rcat)) | "none") - write("numeric(36Rcat) ----> ",image(numeric(36Rcat)) | "none") - write("numeric(36rCAT) ----> ",image(numeric(36rCAT)) | "none") - write("numeric(2r0) ----> ",image(numeric(2r0)) | "none") - write("numeric(+-2) ----> ",image(numeric(+-2)) | "none") - write("numeric(++2) ----> ",image(numeric(++2)) | "none") - write("numeric(--2) ----> ",image(numeric(--2)) | "none") -end - -procedure p6() - write("36 ^ -9 ----> ",image(36 ^ -9) | "none") - write("-36 ^ -9 ----> ",image(-36 ^ -9) | "none") -end - -procedure p7() - write("f := open(\"foo.baz\",\"w\") ----> ",image(f := open("foo.baz","w")) | "none") - write("write(f,\"hello world\") ----> ",image(write(f,"hello world")) | "none") - write("close(f) ----> ",image(close(f)) | "none") -end - -procedure p8() - write("\ncset sizes and images:") - L := [ - '', - '<()>', - '\b\d\e\f\l\n\r\t\v', - &digits, - '0123456789', - '02468' ++ '13579', - ')!@#$%^&*(', - 'the icon programming language', - &lcase, - 'abcdefghijklmnopqrstuvwxyz', - &letters -- &ucase, - 'aBcDeFgHiJkLmNoPqRsTuVwXyZ', - &ucase, - 'ZYXWVUTSRQPONMLKJIHGFEDCBA', - &letters -- &lcase, - 'AbcdEfghIjklmnOpqrstUvwxyz', - 'The Quick Brown Fox Jumped Over The Lazy Gray Dog\'s Back', - &letters, - 'abcdefghijklmnopqrstuvwxyzZYXWVUTSRQPONMLKJIHGFEDCBA', - &lcase ++ &ucase, - 'abcdefghijk|mn.pqrstuvwxyz2YXWVUT5RQP0NMLKJ1HGFEDCBA', - &ascii, - &cset -- ~&ascii, - &cset, - &letters ++ ~&ucase, - &null] - pull(L) - every e := !L do { - s := image(e) # do this first to make image() calc the cset size - s[76:0] := "" - write (right(*e,3), " ", s) - } - write() -end - -procedure p9() - write(image(&ascii) | "failed") - write(image(&cset) | "failed") - write(image(&e) | "failed") - write(image(&fail) | "failed") - write(image(&input) | "failed") - write(image(&lcase) | "failed") - write(image(&null) | "failed") - write(image(&output) | "failed") - write(image(&phi) | "failed") - write(image(&pi) | "failed") - write(image(&pos) | "failed") - write(image(&random) | "failed") - write(image(&subject) | "failed") - write(image(&ucase) | "failed") - exit(abs(3.0)) -end diff --git a/tests/general/checkx.std b/tests/general/checkx.std deleted file mode 100644 index 15bd17f..0000000 --- a/tests/general/checkx.std +++ /dev/null @@ -1,129 +0,0 @@ -image(2) ----> "2" -image('cab') ----> "'abc'" -image(&lcase) ----> "&lcase" -image('abcdefghijklmnopqrstuvwxyz') ----> "&lcase" -image(&input) ----> "&input" -image() ----> "&null" -image(&null) ----> "&null" -image([1,2,3]) ----> "list_1(3)" -image([]) ----> "list_2(0)" -image([,]) ----> "list_3(2)" -image(table()) ----> "table_1(0)" -image(table(3)) ----> "table_2(0)" -image(list(0)) ----> "list_4(0)" -image(repl) ----> "function repl" -image(main) ----> "procedure main" -image(repl(&lcase,10)) ----> "\"abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz\"" -image(array) ----> "record constructor array" -image(a) ----> "&null" -image(array) ----> "record constructor array" -image(image) ----> "function image" -integer(2) ----> 2 -integer("2") ----> 2 -integer(" 2") ----> 2 -integer("2 ") ----> 2 -integer("+2") ----> 2 -integer("-2") ----> -2 -integer("- 2") ----> none -integer(" - 2 ") ----> none -integer("") ----> none -integer("--2") ----> none -integer(" ") ----> none -integer("-") ----> none -integer("+") ----> none -integer("7r4") ----> 4 -integer("4r7") ----> none -integer("4r 7") ----> none -integer("7r 4") ----> none -integer("16rff") ----> 255 -integer("36rcat") ----> 15941 -integer("36Rcat") ----> 15941 -integer("36rCAT") ----> 15941 -integer("1r1") ----> none -integer("2r0") ----> 0 -integer(integer) ----> none -integer := abs ----> function abs -numeric(2) ----> 2 -numeric("2") ----> 2 -numeric(" 2") ----> 2 -numeric("2 ") ----> 2 -numeric("+2") ----> 2 -numeric("-2") ----> -2 -numeric("- 2") ----> none -numeric(" - 2 ") ----> none -numeric("") ----> none -numeric("--2") ----> none -numeric(" ") ----> none -numeric("-") ----> none -numeric("+") ----> none -numeric("7r4") ----> 4 -numeric("4r7") ----> none -numeric("4r 7") ----> none -numeric("7r 4") ----> none -numeric("16rff") ----> 255 -numeric("36rcat") ----> 15941 -numeric("36Rcat") ----> 15941 -numeric("36rCAT") ----> 15941 -numeric("1r1") ----> none -numeric("2r0") ----> 0 -numeric(2) ----> 2 -numeric(2) ----> 2 -numeric(+2) ----> 2 -numeric(-2) ----> -2 -numeric() ----> none -numeric(7r4) ----> 4 -numeric(16rff) ----> 255 -numeric(36rcat) ----> 15941 -numeric(36Rcat) ----> 15941 -numeric(36rCAT) ----> 15941 -numeric(2r0) ----> 0 -numeric(+-2) ----> -2 -numeric(++2) ----> 2 -numeric(--2) ----> 2 -36 ^ -9 ----> 0 --36 ^ -9 ----> 0 -f := open("foo.baz","w") ----> file(foo.baz) -write(f,"hello world") ----> "hello world" -close(f) ----> file(foo.baz) - -cset sizes and images: - 0 '' - 4 '()<>' - 8 '\b\t\n\v\f\r\e\d' - 10 &digits - 10 &digits - 10 &digits - 10 '!#$%&()*@^' - 15 ' aceghilmnoprtu' - 26 &lcase - 26 &lcase - 26 &lcase - 26 'BDFHJLNPRTVXZacegikmoqsuwy' - 26 &ucase - 26 &ucase - 26 &ucase - 26 'AEIOUbcdfghjklmnpqrstvwxyz' - 31 ' \'BDFGJLOQTacdeghikmnoprsuvwxyz' - 52 &letters - 52 &letters - 52 &letters - 52 '.0125ABCDEFGHJKLMNPQRTUVWXYabcdefghijkmnpqrstuvwxyz|' -128 &ascii -128 &ascii -256 &cset -256 &cset - -&ascii -&cset -2.718281828 -failed -&input -&lcase -&null -&output -1.618033989 -3.141592654 -1 -0 -"" -&ucase diff --git a/tests/general/extlvals.icn b/tests/general/extlvals.icn new file mode 100644 index 0000000..0f394ba --- /dev/null +++ b/tests/general/extlvals.icn @@ -0,0 +1,71 @@ +# Test use of external values with dynamic loading, using demo cfunc. + +link cfunc + +record complex(r, i) + +procedure main() + local e, l, v1, v2, v3, v4 + local r1,r2,r3,r4, s1, s2, s3, s4 + + # test simple creation, type(), copy() + xwrite("v1", v1 := extxmin()) + xwrite("v2", v2 := extxmin()) + xwrite("v3", v3 := v1) + xwrite("v4", v4 := copy(v1)) + + # test string-based external example + xwrite("s1", s1 := extxstr("bite")) + xwrite("s2", s2 := extxstr("the")) + xwrite("s3", s3 := extxstr("wax")) + xwrite("s4", s4 := extxstr("tadpole")) + + # test real-based external example + xwrite("r1", r1 := extxreal(111.1)) + xwrite("r2", r2 := extxreal(222.2)) + xwrite("r3", r3 := extxreal(333.3)) + xwrite("r4", r4 := copy(r1)) + + # test === and ~=== + teqv(v1, v3, v2) + teqv(v1, v4, v2) + teqv(s2, copy(s2), s3) + teqv(r1, r1, copy(r1)) + teqv(s1, s1, s3) + teqv(r2, r2, r4) + teqv(s3, s3, r3) + + # test sorting + l := [ v1, s2, r3, v4, s1, r2, complex(8,9), v3, s4, r1, v2, s3, r4 ] + write() + every xwrite("before", !l) + write() + every xwrite("sorted", !sort(l)) + +end + + +# write label, type(xval), image(xval) + +procedure xwrite(label, xval) + write(label, ": ", type(xval), ": ",image(xval)) + return +end + + +# test equivalence of id1 and id2, and nonequivalence of diff + +procedure teqv(id1, id2, diff) + if id1 ~=== id2 then + write("nonequivalent: ", image(id1), " and ", image(id2)) + if id2 ~=== id1 then + write("nonequivalent: ", image(id2), " and ", image(id1)) + if not (id1 === id2) then + write("not equivalent: ", image(id1), " and ", image(id2)) + + if id1 === diff then + write("false equivalence: ", image(id1), " and ", image(diff)) + if id2 === diff then + write("false equivalence: ", image(id2), " and ", image(diff)) + return +end diff --git a/tests/general/extlvals.std b/tests/general/extlvals.std new file mode 100644 index 0000000..0141f3b --- /dev/null +++ b/tests/general/extlvals.std @@ -0,0 +1,40 @@ +v1: external: external_1(0) +v2: external: external_2(0) +v3: external: external_1(0) +v4: external: external_1(0) +s1: xstr: xstr_3(00324:bite) +s2: xstr: xstr_4(31681:the) +s3: xstr: xstr_5(35548:wax) +s4: xstr: xstr_6(46645:tadpole) +r1: xreal: xreal_7(111.1) +r2: xreal: xreal_8(222.2) +r3: xreal: xreal_9(333.3) +r4: xreal: xreal_10(111.1) + +before: external: external_1(0) +before: xstr: xstr_4(31681:the) +before: xreal: xreal_9(333.3) +before: external: external_1(0) +before: xstr: xstr_3(00324:bite) +before: xreal: xreal_8(222.2) +before: complex: record complex_1(2) +before: external: external_1(0) +before: xstr: xstr_6(46645:tadpole) +before: xreal: xreal_7(111.1) +before: external: external_2(0) +before: xstr: xstr_5(35548:wax) +before: xreal: xreal_10(111.1) + +sorted: complex: record complex_1(2) +sorted: external: external_1(0) +sorted: external: external_1(0) +sorted: external: external_1(0) +sorted: external: external_2(0) +sorted: xreal: xreal_7(111.1) +sorted: xreal: xreal_10(111.1) +sorted: xreal: xreal_8(222.2) +sorted: xreal: xreal_9(333.3) +sorted: xstr: xstr_3(00324:bite) +sorted: xstr: xstr_4(31681:the) +sorted: xstr: xstr_5(35548:wax) +sorted: xstr: xstr_6(46645:tadpole) diff --git a/tests/general/features.icn b/tests/general/features.icn new file mode 100644 index 0000000..2eb3f4f --- /dev/null +++ b/tests/general/features.icn @@ -0,0 +1,44 @@ +# Check and report configuration options +# as reported by preprocessor symbols and &features +# +# Compile WITHOUT using -u + +global error + +procedure main() + write("Features found:") + ckfeat(_UNIX, "UNIX") + ckfeat(_MACINTOSH, "Macintosh") + ckfeat(_CYGWIN, "Cygwin") + ckfeat(_MS_WINDOWS, "MS Windows") + ckfeat(_ASCII, "ASCII") + ckfeat(_CO_EXPRESSIONS, "co-expressions") + ckfeat(_DYNAMIC_LOADING, "dynamic loading") + ckfeat(_EXTERNAL_VALUES, "external values") + ckfeat(_KEYBOARD_FUNCTIONS, "keyboard functions") + ckfeat(_LARGE_INTEGERS, "large integers") + ckfeat(_PIPES, "pipes") + ckfeat(_SYSTEM_FUNCTION, "system function") + ckfeat(_GRAPHICS, "graphics") + ckfeat(_X_WINDOW_SYSTEM, "X Windows") + + if \error then exit(1) +end + +procedure ckfeat(ppval, fstring) + if ppval === 1 then + if &features == fstring then + write(" ", fstring) + else + error := write(" ", fstring, " (PREPROCESSOR SYMBOL ONLY)") + else if \ppval then + if &features == fstring then + error := write(" ", fstring, " (WITH BOGUS PREPROCESSOR SYMBOL: ", + image(ppval), ")") + else + error := write(" ", fstring, " (ONLY BOGUS PREPROCESSOR SYMBOL: ", + image(ppval), ")") + else if &features == fstring then + error := write(" ", fstring, " (WITHOUT PREPROCESSOR SYMBOL)") + return +end diff --git a/tests/general/ilib.icn b/tests/general/ilib.icn index eb019a0..bfdc1af 100644 --- a/tests/general/ilib.icn +++ b/tests/general/ilib.icn @@ -1,14 +1,16 @@ # a simple test of many of the core library procedures +# (and a few things outside the core) link core link options +link printf link rational $define LSIZE 16 $define GENLIMIT 25 procedure main() - local L, LR, T, r1, r2, r3, argv, SL + local L, LR, T, r1, r2, r3, argv, SL, vlist, v L := [3, 1, 4, 1, 5, 9, 2, 6, 5, 3, 5] LR := lreverse(L) @@ -170,6 +172,15 @@ procedure main() every writes(" ", " argv " | !argv | "\n") write() + write("printf:") # printf (not part of core) + vlist := [ + "-1234.5678", -654.3209, -12.34567, -7.0486, -5, -3.9999, + -0.7032, -0.0028, -0.0009, -0.0003, 0.0, 0, 0.003, 0.0058, + 0.1234, 0.5678, &phi, &e, &pi, 718.93, 123456, 4.97e8 ] + every v := !vlist do + printf("%8.3d %06o %5x %8.3e %8.3r %.3r\n", v, v, v, v, v, v) + + write() write("random:") # random gen(rand_num) gen(rand_int, 20) diff --git a/tests/general/ilib.std b/tests/general/ilib.std index 83d82f1..c05ce85 100644 --- a/tests/general/ilib.std +++ b/tests/general/ilib.std @@ -159,6 +159,30 @@ options abc:- i:1 r:1 s:-v options a:bc i:42 r:1 s:1 v:1 argv - 98.6 -b x y +printf: + -1234 37777775456 fffffb2e -1.23e+3 -1234.568 -1234.568 + -654 37777776562 fffffd72 -6.54e+2 -654.321 -654.321 + -12 37777777764 fffffff4 -1.23e+1 -12.346 -12.346 + -7 37777777771 fffffff9 -7.049e0 -7.049 -7.049 + -5 37777777773 fffffffb -5.000e0 -5.000 -5.000 + -3 37777777775 fffffffd -4.000e0 -4.000 -4.000 + 0 000000 0 -7.03e-1 -0.703 -0.703 + 0 000000 0 -2.80e-3 -0.003 -0.003 + 0 000000 0 -9.00e-4 -0.001 -0.001 + 0 000000 0 -3.00e-4 -0.000 -0.000 + 0 000000 0 0.000e0 0.000 0.000 + 0 000000 0 0.000e0 0.000 0.000 + 0 000000 0 3.000e-3 0.003 0.003 + 0 000000 0 5.800e-3 0.006 0.006 + 0 000000 0 1.234e-1 0.123 0.123 + 0 000000 0 5.678e-1 0.568 0.568 + 1 000001 1 1.618e0 1.618 1.618 + 2 000002 2 2.718e0 2.718 2.718 + 3 000003 3 3.142e0 3.142 3.142 + 718 001316 2ce 7.189e+2 718.930 718.930 + 123456 361100 1e240 1.235e+5 123456.000 123456.000 +497000000 3547717100 1d9f9e40 4.970e+8 497000000.000 497000000.000 + random: rand_num 453816694 rand_int 9 diff --git a/tests/general/io.icn b/tests/general/io.icn index fec8522..826ef83 100644 --- a/tests/general/io.icn +++ b/tests/general/io.icn @@ -3,11 +3,10 @@ # I/O test -- writes ./tmp1 and ./tmp2 as well as stdout procedure main() - local L, f, m, n, t1, t2 + local L, f, n, t1, t2 L := [&input, &output, &errout, - m := open("/etc/motd") | stop("no /etc/motd"), - n := open("/dev/null", "w") | stop("no /dev/null")] + n := open("/dev/null", "w") | stop("no /dev/null")] L := sort(L) every f := !L do write(type(f), ": ", image(f)) @@ -21,12 +20,6 @@ procedure main() every write(!&input) \ 2 write() - write("flush /etc/motd: ", image(flush(m)) | "FAILED") - write("close /etc/motd: ", image(close(m)) | "FAILED") - write("close /etc/motd: ", image(close(m)) | "FAILED") - write("flush /etc/motd: ", image(flush(m)) | "FAILED") - - write() write("flush /dev/null: ", image(flush(n)) | "FAILED") write("close /dev/null: ", image(close(n)) | "FAILED") write("close /dev/null: ", image(close(n)) | "FAILED") @@ -103,8 +96,8 @@ procedure wfile(name, mode, s) writes(s) tab(many(' ')) while not pos(0) do { - write(f, tab(upto(' ') | 0)) - tab(many(' ')) + write(f, tab(upto(' ') | 0)) + tab(many(' ')) } write(" : ", where(f)) flush(f) diff --git a/tests/general/io.std b/tests/general/io.std index b512c97..ea70777 100644 --- a/tests/general/io.std +++ b/tests/general/io.std @@ -2,7 +2,6 @@ file: &errout file: &input file: &output file: file(/dev/null) -file: file(/etc/motd) aaa bbbb @@ -13,11 +12,6 @@ ffffffff ggggggggg hhhhhhhhhh -flush /etc/motd: file(/etc/motd) -close /etc/motd: file(/etc/motd) -close /etc/motd: file(/etc/motd) -flush /etc/motd: file(/etc/motd) - flush /dev/null: file(/dev/null) close /dev/null: file(/dev/null) close /dev/null: file(/dev/null) @@ -106,11 +100,11 @@ file(sed 's/^/=()= /' io.icn) > =()= # I/O test -- writes ./tmp1 and ./tmp2 as well as stdout > =()= > =()= procedure main() -> =()= local L, f, m, n, t1, t2 +> =()= local L, f, n, t1, t2 > =()= > =()= L := [&input, &output, &errout, -> =()= m := open("/etc/motd") | stop("no /etc/motd"), -> =()= n := open("/dev/null", "w") | stop("no /dev/null")] +> =()= n := open("/dev/null", "w") | stop("no /dev/null")] +> =()= L := sort(L) file(ls io.i?n io.d?t io.s?d) > io.dat diff --git a/tests/general/kwds.icn b/tests/general/kwds.icn index 3db341f..242a080 100644 --- a/tests/general/kwds.icn +++ b/tests/general/kwds.icn @@ -27,8 +27,9 @@ procedure main() every kw("fail", &fail | "[failed]") every insert(f := set(), &features) - every delete(f, "UNIX" | "MS Windows" | "Cygwin") # platform ID - every delete(f, "dynamic loading" | "graphics" | "X Windows") # may be absent + every delete(f, "UNIX" | "Macintosh" | "MS Windows" | "Cygwin") # platform ID + every delete(f, "dynamic loading" | "external values") # may be absent + every delete(f, "graphics" | "X Windows") # may be absent every kw("features", member(f, &features)) every kw("input", &input | "[failed]") diff --git a/tests/general/prepro.icn b/tests/general/prepro.icn index 0b9972a..262b460 100644 --- a/tests/general/prepro.icn +++ b/tests/general/prepro.icn @@ -64,6 +64,7 @@ procedure main() precheck(_EVENT_MONITOR, "event monitoring") precheck(_EXECUTABLE_IMAGES, "executable images") precheck(_EXTERNAL_FUNCTIONS,"external functions") + precheck(_EXTERNAL_VALUES, "external values") precheck(_KEYBOARD_FUNCTIONS,"keyboard functions") precheck(_LARGE_INTEGERS, "large integers") precheck(_MEMORY_MONITOR, "memory monitoring") diff --git a/tests/general/techo.icn b/tests/general/techo.icn new file mode 100644 index 0000000..aa6fe71 --- /dev/null +++ b/tests/general/techo.icn @@ -0,0 +1,63 @@ +global time, date, save, wombats + +# All variables passed to echo() must be: + +# Simple scalar variables, because echo() does not yet understand +# Icon keywords (such as &clock), arrays, records, or function +# calls. However, such entities may be assigned to simple global +# variables, as the main program below shows; and + +# Global, because echo() cannot accesss their values otherwise. + +# If a variable is undefined or null, echo() outputs nothing. + +link echo + +procedure main() + time := "12:34:56" # fake &clock for reproducible test + date := "2010/02/30" # fake &date for reproducible test + save := 47.23 + wombats := 22 + + # Usage method 1: + + "It is now $time on $date and you have savings of $$$save." ? echo() + "The number of wombats is $wombats." ? echo() + "It is now ${time} on ${date} and you have ${wombats} wombats." ? echo() + "There is no global variable named \"$foo\"." ? echo() + "This does not work: It is now ${&clock}." ? echo() + echo() + "The previous echo() example printed an empty line." ? echo() + echo() + "Here is another way to use echo()..." ? echo() + echo() + + # Usage method 2: + + "It is now $time on $date and you have savings of $$$save." | + "The number of wombats is $wombats." | + "It is now ${time} on ${date} and you have ${wombats} wombats." | + "There is no global variable named \"$foo\"." | + "This does not work: It is now ${&clock}." | + "" | + "The previous input line printed an empty output line." ? echo() + + # The value of &subject defaults to "", so echo() will print out an + # empty line if it is called without a `?'. + + echo() + + # The next test takes advantage of the fact that string + # concatenation has a higher precedence than alternation. It + # prints three lines: + + "Fee, " || + "fi, " || + "fo, " || + "fum, " | # 1st line + "I " || + "smell " || + "the blood " | # 2nd line + "of an Englishman!" ? echo() #3rd line + +end diff --git a/tests/general/techo.std b/tests/general/techo.std new file mode 100644 index 0000000..686830a --- /dev/null +++ b/tests/general/techo.std @@ -0,0 +1,21 @@ +It is now 12:34:56 on 2010/02/30 and you have savings of $47.23. +The number of wombats is 22. +It is now 12:34:56 on 2010/02/30 and you have 22 wombats. +There is no global variable named "". +This does not work: It is now . + +The previous echo() example printed an empty line. + +Here is another way to use echo()... + +It is now 12:34:56 on 2010/02/30 and you have savings of $47.23. +The number of wombats is 22. +It is now 12:34:56 on 2010/02/30 and you have 22 wombats. +There is no global variable named "". +This does not work: It is now . + +The previous input line printed an empty output line. + +Fee, fi, fo, fum, +I smell the blood +of an Englishman! diff --git a/tests/general/tpp.icn b/tests/general/tpp.icn index b2a7e82..c326c3c 100644 --- a/tests/general/tpp.icn +++ b/tests/general/tpp.icn @@ -74,8 +74,8 @@ $include"tpp3.icn"#likewise $line 0 "predef.tst" #== predef test == -should be defined as 1: _UNIX _ASCII _PIPES _SYSTEM_FUNCTION -should not be defined: _MACINTOSH _VMS _EBCDIC _DOS_FUNCTIONS +should be defined as 1: _ASCII _PIPES _SYSTEM_FUNCTION +should not be defined: _VMS _EBCDIC _DOS_FUNCTIONS it depends: _COMPILED _INTERPRETED $undef _PIPES $undef _ASCII diff --git a/tests/general/tpp.ok b/tests/general/tpp.ok index 004f79a..a309f8a 100644 --- a/tests/general/tpp.ok +++ b/tests/general/tpp.ok @@ -161,8 +161,8 @@ $( digraphs for EBCDIC $) #line 0 "predef.tst" #== predef test == -should be defined as 1: 1 1 1 1 -should not be defined: _MACINTOSH _VMS _EBCDIC _DOS_FUNCTIONS +should be defined as 1: 1 1 1 +should not be defined: _VMS _EBCDIC _DOS_FUNCTIONS it depends: _COMPILED _INTERPRETED @@ -560,6 +560,6 @@ c c c c c c c c c c c c c c c c c c c c c c c c c c c pipes:1 ascii:1 ebcdic:_EBCDIC # were redefined in tpp.icn -should be defined as 1: 1 1 1 1 -should not be defined: _MACINTOSH _VMS _EBCDIC _DOS_FUNCTIONS +should be defined as 1: 1 1 1 +should not be defined: _VMS _EBCDIC _DOS_FUNCTIONS it depends: _COMPILED _INTERPRETED diff --git a/tests/general/tpp9.icn b/tests/general/tpp9.icn index ee52472..5cc063f 100644 --- a/tests/general/tpp9.icn +++ b/tests/general/tpp9.icn @@ -3,6 +3,6 @@ pipes:_PIPES ascii:_ASCII ebcdic:_EBCDIC # were redefined in tpp.icn -should be defined as 1: _UNIX _ASCII _PIPES _SYSTEM_FUNCTION -should not be defined: _MACINTOSH _VMS _EBCDIC _DOS_FUNCTIONS +should be defined as 1: _ASCII _PIPES _SYSTEM_FUNCTION +should not be defined: _VMS _EBCDIC _DOS_FUNCTIONS it depends: _COMPILED _INTERPRETED diff --git a/tests/general/tprintf.icn b/tests/general/tprintf.icn new file mode 100644 index 0000000..2ea8eb3 --- /dev/null +++ b/tests/general/tprintf.icn @@ -0,0 +1,22 @@ +# test the library printf procedure +# +# also incidentally tests large integers, real arithmetic, etc. + +link printf + +procedure main() + local v, vlist + + vlist := [ -16r80000000, -16r7FFFFFFF, -16r40000000, -16r3FFFFFFF, + -16r10000, -16RFFFF, -20104, -719, -2, -1, 0, 1, 2, 7, 15, 47, 11213, + 16rFFFF, 16r10000, 16r7FFFFFFF, 16r80000000, 16rFFFFFFFF, 16r100000000, + 0.125, &phi, &e, &pi, "4.56789", 16.0, 1024.0, 65536.0, 5e12, 6.02e23 ] + + every v := !vlist | realseq() | -realseq() do + printf("%16s %15.3r %10.3e %11d %12o %9x\n", v, v, v, v, v, v) +end + +procedure realseq() + suspend 0.0 + suspend 10.0 ^ (-12 to 30) * (1.0 | 13./9 | 3./2 | 5./2. | 14./9 ) +end diff --git a/tests/general/tprintf.std b/tests/general/tprintf.std new file mode 100644 index 0000000..8893450 --- /dev/null +++ b/tests/general/tprintf.std @@ -0,0 +1,465 @@ + -2147483648 -2147483648.000 -2.147e+9 -2147483648 20000000000 80000000 + -2147483647 -2147483647.000 -2.147e+9 -2147483647 20000000001 80000001 + -1073741824 -1073741824.000 -1.074e+9 -1073741824 30000000000 c0000000 + -1073741823 -1073741823.000 -1.074e+9 -1073741823 30000000001 c0000001 + -65536 -65536.000 -6.554e+4 -65536 37777600000 ffff0000 + -65535 -65535.000 -6.554e+4 -65535 37777600001 ffff0001 + -20104 -20104.000 -2.010e+4 -20104 37777730570 ffffb178 + -719 -719.000 -7.190e+2 -719 37777776461 fffffd31 + -2 -2.000 -2.000e0 -2 37777777776 fffffffe + -1 -1.000 -1.000e0 -1 37777777777 ffffffff + 0 0.000 0.000e0 0 0 0 + 1 1.000 1.000e0 1 1 1 + 2 2.000 2.000e0 2 2 2 + 7 7.000 7.000e0 7 7 7 + 15 15.000 1.500e+1 15 17 f + 47 47.000 4.700e+1 47 57 2f + 11213 11213.000 1.121e+4 11213 25715 2bcd + 65535 65535.000 6.554e+4 65535 177777 ffff + 65536 65536.000 6.554e+4 65536 200000 10000 + 2147483647 2147483647.000 2.147e+9 2147483647 17777777777 7fffffff + 2147483648 2147483648.000 2.147e+9 2147483648 20000000000 80000000 + 4294967295 4294967295.000 4.295e+9 4294967295 37777777777 ffffffff + 4294967296 4294967296.000 4.295e+9 4294967296 40000000000 100000000 + 0.125 0.125 1.250e-1 0 0 0 + 1.618033989 1.618 1.618e0 1 1 1 + 2.718281828 2.718 2.718e0 2 2 2 + 3.141592654 3.142 3.142e0 3 3 3 + 4.56789 4.568 4.568e0 4 4 4 + 16.0 16.000 1.600e+1 16 20 10 + 1024.0 1024.000 1.024e+3 1024 2000 400 + 65536.0 65536.000 6.554e+4 65536 200000 10000 + 5e+12 5000000000000.000 5.000e+12 5000000000000 110604716250000 48c27395000 + 6.02e+23 602000000000000014596177.920 6.020e+23 601999999999999995805696 177364761025064660400000000 7f7a7c42a34d84000000 + 0.0 0.000 0.000e0 0 0 0 + 1e-12 0.000 1.000e-12 0 0 0 + 1.444444444e-12 0.000 1.444e-12 0 0 0 + 1.5e-12 0.000 1.500e-12 0 0 0 + 2.5e-12 0.000 2.500e-12 0 0 0 + 1.555555556e-12 0.000 1.556e-12 0 0 0 + 1e-11 0.000 1.000e-11 0 0 0 + 1.444444444e-11 0.000 1.444e-11 0 0 0 + 1.5e-11 0.000 1.500e-11 0 0 0 + 2.5e-11 0.000 2.500e-11 0 0 0 + 1.555555556e-11 0.000 1.556e-11 0 0 0 + 1e-10 0.000 1.000e-10 0 0 0 + 1.444444444e-10 0.000 1.444e-10 0 0 0 + 1.5e-10 0.000 1.500e-10 0 0 0 + 2.5e-10 0.000 2.500e-10 0 0 0 + 1.555555556e-10 0.000 1.556e-10 0 0 0 + 1e-09 0.000 1.000e-9 0 0 0 + 1.444444444e-09 0.000 1.444e-9 0 0 0 + 1.5e-09 0.000 1.500e-9 0 0 0 + 2.5e-09 0.000 2.500e-9 0 0 0 + 1.555555556e-09 0.000 1.556e-9 0 0 0 + 1e-08 0.000 1.000e-8 0 0 0 + 1.444444444e-08 0.000 1.444e-8 0 0 0 + 1.5e-08 0.000 1.500e-8 0 0 0 + 2.5e-08 0.000 2.500e-8 0 0 0 + 1.555555556e-08 0.000 1.556e-8 0 0 0 + 1e-07 0.000 1.000e-7 0 0 0 + 1.444444444e-07 0.000 1.444e-7 0 0 0 + 1.5e-07 0.000 1.500e-7 0 0 0 + 2.5e-07 0.000 2.500e-7 0 0 0 + 1.555555556e-07 0.000 1.556e-7 0 0 0 + 1e-06 0.000 1.000e-6 0 0 0 + 1.444444444e-06 0.000 1.444e-6 0 0 0 + 1.5e-06 0.000 1.500e-6 0 0 0 + 2.5e-06 0.000 2.500e-6 0 0 0 + 1.555555556e-06 0.000 1.556e-6 0 0 0 + 1e-05 0.000 1.000e-5 0 0 0 + 1.444444444e-05 0.000 1.444e-5 0 0 0 + 1.5e-05 0.000 1.500e-5 0 0 0 + 2.5e-05 0.000 2.500e-5 0 0 0 + 1.555555556e-05 0.000 1.556e-5 0 0 0 + 0.0001 0.000 1.000e-4 0 0 0 + 0.0001444444444 0.000 1.444e-4 0 0 0 + 0.00015 0.000 1.500e-4 0 0 0 + 0.00025 0.000 2.500e-4 0 0 0 + 0.0001555555556 0.000 1.556e-4 0 0 0 + 0.001 0.001 1.000e-3 0 0 0 + 0.001444444444 0.001 1.444e-3 0 0 0 + 0.0015 0.002 1.500e-3 0 0 0 + 0.0025 0.003 2.500e-3 0 0 0 + 0.001555555556 0.002 1.556e-3 0 0 0 + 0.01 0.010 1.000e-2 0 0 0 + 0.01444444444 0.014 1.444e-2 0 0 0 + 0.015 0.015 1.500e-2 0 0 0 + 0.025 0.025 2.500e-2 0 0 0 + 0.01555555556 0.016 1.556e-2 0 0 0 + 0.1 0.100 1.000e-1 0 0 0 + 0.1444444444 0.144 1.444e-1 0 0 0 + 0.15 0.150 1.500e-1 0 0 0 + 0.25 0.250 2.500e-1 0 0 0 + 0.1555555556 0.156 1.556e-1 0 0 0 + 1.0 1.000 1.000e0 1 1 1 + 1.444444444 1.444 1.444e0 1 1 1 + 1.5 1.500 1.500e0 1 1 1 + 2.5 2.500 2.500e0 2 2 2 + 1.555555556 1.556 1.556e0 1 1 1 + 10.0 10.000 1.000e+1 10 12 a + 14.44444444 14.444 1.444e+1 14 16 e + 15.0 15.000 1.500e+1 15 17 f + 25.0 25.000 2.500e+1 25 31 19 + 15.55555556 15.556 1.556e+1 15 17 f + 100.0 100.000 1.000e+2 100 144 64 + 144.4444444 144.444 1.444e+2 144 220 90 + 150.0 150.000 1.500e+2 150 226 96 + 250.0 250.000 2.500e+2 250 372 fa + 155.5555556 155.556 1.556e+2 155 233 9b + 1000.0 1000.000 1.000e+3 1000 1750 3e8 + 1444.444444 1444.444 1.444e+3 1444 2644 5a4 + 1500.0 1500.000 1.500e+3 1500 2734 5dc + 2500.0 2500.000 2.500e+3 2500 4704 9c4 + 1555.555556 1555.556 1.556e+3 1555 3023 613 + 10000.0 10000.000 1.000e+4 10000 23420 2710 + 14444.44444 14444.444 1.444e+4 14444 34154 386c + 15000.0 15000.000 1.500e+4 15000 35230 3a98 + 25000.0 25000.000 2.500e+4 25000 60650 61a8 + 15555.55556 15555.556 1.556e+4 15555 36303 3cc3 + 100000.0 100000.000 1.000e+5 100000 303240 186a0 + 144444.4444 144444.444 1.444e+5 144444 432074 2343c + 150000.0 150000.000 1.500e+5 150000 444760 249f0 + 250000.0 250000.000 2.500e+5 250000 750220 3d090 + 155555.5556 155555.556 1.556e+5 155555 457643 25fa3 + 1000000.0 1000000.000 1.000e+6 1000000 3641100 f4240 + 1444444.444 1444444.444 1.444e+6 1444444 5405134 160a5c + 1500000.0 1500000.000 1.500e+6 1500000 5561540 16e360 + 2500000.0 2500000.000 2.500e+6 2500000 11422640 2625a0 + 1555555.556 1555555.556 1.556e+6 1555555 5736143 17bc63 + 10000000.0 10000000.000 1.000e+7 10000000 46113200 989680 + 14444444.44 14444444.444 1.444e+7 14444444 67063634 dc679c + 15000000.0 15000000.000 1.500e+7 15000000 71160700 e4e1c0 + 25000000.0 25000000.000 2.500e+7 25000000 137274100 17d7840 + 15555555.56 15555555.556 1.556e+7 15555555 73255743 ed5be3 + 100000000.0 100000000.000 1.000e+8 100000000 575360400 5f5e100 + 144444444.4 144444444.444 1.444e+8 144444444 1047006034 89c0c1c + 150000000.0 150000000.000 1.500e+8 150000000 1074150600 8f0d180 + 250000000.0 250000000.000 2.500e+8 250000000 1671531200 ee6b280 + 155555555.6 155555555.556 1.556e+8 155555555 1121313343 94596e3 + 1000000000.0 1000000000.000 1.000e+9 1000000000 7346545000 3b9aca00 + 1444444444.0 1444444444.444 1.444e+9 1444444444 12606074434 5618791c + 1500000000.0 1500000000.000 1.500e+9 1500000000 13132027400 59682f00 + 2500000000.0 2500000000.000 2.500e+9 2500000000 22500574400 9502f900 + 1555555556.0 1555555555.556 1.556e+9 1555555555 13455762343 5cb7e4e3 + 1e+10 10000000000.000 1.000e+10 10000000000 112402762000 2540be400 + 1.444444444e+10 14444444444.444 1.444e+10 14444444444 153475135434 35cf4bb1c + 1.5e+10 15000000000.000 1.500e+10 15000000000 157604353000 37e11d600 + 2.5e+10 25000000000.000 2.500e+10 25000000000 272207335000 5d21dba00 + 1.555555556e+10 15555555555.556 1.556e+10 15555555555 163713570343 39f2ef0e3 + 1e+11 100000000000.000 1.000e+11 100000000000 1351035564000 174876e800 + 1.444444444e+11 144444444444.444 1.444e+11 144444444444 2064143647434 21a18f4f1c + 1.5e+11 150000000000.000 1.500e+11 150000000000 2135454456000 22ecb25c00 + 2.5e+11 250000000000.000 2.500e+11 250000000000 3506512242000 3a35294400 + 1.555555556e+11 155555555555.556 1.556e+11 155555555555 2206765264343 2437d568e3 + 1e+12 1000000000000.000 1.000e+12 1000000000000 16432451210000 e8d4a51000 + 1.444444444e+12 1444444444444.444 1.444e+12 1444444444444 25011746213434 1504f99171c + 1.5e+12 1500000000000.000 1.500e+12 1500000000000 25647675714000 15d3ef79800 + 2.5e+12 2500000000000.000 2.500e+12 2500000000000 44302347124000 246139ca800 + 1.555555556e+12 1555555555555.556 1.556e+12 1555555555555 26505625414343 16a2e5618e3 + 1e+13 10000000000000.000 1.000e+13 10000000000000 221411634520000 9184e72a000 + 1.444444444e+13 14444444444444.444 1.444e+13 14444444444444 322143376563434 d231bfae71c + 1.5e+13 15000000000000.000 1.500e+13 15000000000000 332216552770000 da475abf000 + 2.5e+13 25000000000000.000 2.500e+13 25000000000000 553630407510000 16bcc41e9000 + 1.555555556e+13 15555555555555.556 1.556e+13 15555555555555 342271727174343 e25cf5cf8e3 + 1e+14 100000000000000.000 1.000e+14 100000000000000 2657142036440000 5af3107a4000 + 1.444444444e+14 144444444444444.448 1.444e+14 144444444444444 4065742763203434 835f17cd071c + 1.5e+14 150000000000000.000 1.500e+14 150000000000000 4206623055660000 886c98b76000 + 2.5e+14 250000000000000.000 2.500e+14 250000000000000 7065765114320000 e35fa931a000 + 1.555555556e+14 155555555555555.552 1.556e+14 155555555555555 4327503150334343 8d7a19a1b8e3 + 1e+15 1000000000000000.000 1.000e+15 1000000000000000 34327724461500000 38d7ea4c68000 + 1.444444444e+15 1444444444444444.416 1.444e+15 1444444444444444 51033335600443434 521b6ee02471c + 1.5e+15 1500000000000000.000 1.500e+15 1500000000000000 52503676712340000 5543df729c000 + 2.5e+15 2500000000000000.000 2.500e+15 2500000000000000 107033623374040000 8e1bc9bf04000 + 1.555555556e+15 1555555555555555.584 1.556e+15 1555555555555555 54154240024234343 586c5005138e3 + 1e+16 10000000000000000.000 1.000e+16 10000000000000000 434157115760200000 2386f26fc10000 + 1.444444444e+16 14444444444444444.672 1.444e+16 14444444444444444 632422251405543434 3351254c16c71c + 1.5e+16 15000000000000000.000 1.500e+16 15000000000000000 652246564750300000 354a6ba7a18000 + 2.5e+16 25000000000000000.000 2.500e+16 25000000000000000 1306425702730500000 58d15e17628000 + 1.555555556e+16 15555555555555555.328 1.556e+16 15555555555555556 672073100313034344 3743b2032c38e4 + 1e+17 100000000000000000.000 1.000e+17 100000000000000000 5432127413542400000 16345785d8a0000 + 1.444444444e+17 144444444444444442.624 1.444e+17 144444444444444448 10011267237070743440 2012b74f8e3c720 + 1.5e+17 150000000000000000.000 1.500e+17 150000000000000000 10247203221423600000 214e8348c4f0000 + 2.5e+17 250000000000000000.000 2.500e+17 250000000000000000 15701332635166200000 3782dace9d90000 + 1.555555556e+17 155555555555555540.992 1.556e+17 155555555555555552 10505117203756434340 228a4f41fba38e0 + 1e+18 1000000000000000000.000 1.000e+18 1000000000000000000 67405553164731000000 de0b6b3a7640000 + 1.444444444e+18 1444444444444444327.936 1.444e+18 1444444444444444416 120135451067071343400 140bb291b8e5c700 + 1.5e+18 1500000000000000000.000 1.500e+18 1500000000000000000 123210440657305400000 14d1120d7b160000 + 2.5e+18 2500000000000000000.000 2.500e+18 2500000000000000000 212616214044236400000 22b1c8c1227a0000 + 1.555555556e+18 1555555555555555672.064 1.556e+18 1555555555555555584 126263430447521434400 159671893d463900 + 1e+19 10000000000000000000.000 1.000e+19 10000000000000000000 1053071060221172000000 8ac7230489e80000 + 1.444444444e+19 14444444444444445376.512 1.444e+19 14444444444444444672 1441647633047076344000 c874f9b138f9c800 + 1.5e+19 15000000000000000000.000 1.500e+19 15000000000000000000 1500525510331667000000 d02ab486cedc0000 + 2.5e+19 24999999999999997902.848 2.500e+19 25000000000000000000 2553616570553061000000 15af1d78b58c40000 + 1.555555556e+19 15555555555555554623.488 1.556e+19 15555555555555555328 1537403365614457434000 d7e06f5c64be3800 + 1e+20 99999999999999991611.392 1.000e+20 100000000000000000000 12657072742654304000000 56bc75e2d63100000 + 1.444444444e+20 144444444444444445376.512 1.444e+20 144444444444444442624 17522216016607160340000 7d491c0ec39c1c000 + 1.5e+20 150000000000000004194.304 1.500e+20 150000000000000000000 20206530324202446000000 821ab0d4414980000 + 2.5e+20 249999999999999995805.696 2.500e+20 250000000000000000000 33065623267056752000000 d8d726b7177a80000 + 1.555555556e+20 155555555555555579789.312 1.556e+20 155555555555555573760 20673042631575733500000 86ec4599bef6e8000 + 1e+21 999999999999999983222.784 1.000e+21 1000000000000000000000 154327115334273650000000 3635c9adc5dea00000 + 1.444444444e+21 1444444444444444420210.688 1.444e+21 1444444444444444327936 234466614223510144000000 4e4db1893a41900000 + 1.5e+21 1499999999999999974834.176 1.500e+21 1500000000000000000000 242502564112431574000000 5150ae84a8cdf00000 + 2.5e+21 2500000000000000226492.416 2.500e+21 2500000000000000000000 417031701446725444000000 878678326eac900000 + 1.555555556e+21 1555555555555555797893.120 1.556e+21 1555555555555555672064 250516534001353224000000 5453ab80175a500000 + 1e+22 10000000000000000905969.664 1.000e+22 10000000000000000000000 2074147406233526220000000 21e19e0c9bab2400000 + 1.444444444e+22 14444444444444443128365.056 1.444e+22 14444444444444443279360 3036043572704321750000000 30f08ef5c468fa00000 + 1.5e+22 15000000000000000285212.672 1.500e+22 15000000000000000000000 3132233211351401330000000 32d26d12e980b600000 + 2.5e+22 24999999999999996896215.040 2.500e+22 24999999999999997902848 5226402617605127540000000 54b40b1f852bd800000 + 1.555555556e+22 15555555555555557442060.288 1.556e+22 15555555555555556720640 3226422630016460710000000 34b44b300e987200000 + 1e+23 99999999999999987584860.160 1.000e+23 99999999999999991611392 25132013077024536600000000 152d02c7e14af6000000 + 1.444444444e+23 144444444444444422693715.968 1.444e+23 144444444444444428599296 36454545314654063400000000 1e9659599ac19c000000 + 1.5e+23 149999999999999981377290.240 1.500e+23 149999999999999987417088 37607020536437016100000000 1fc3842bd1f071000000 + 2.5e+23 250000000000000003321888.768 2.500e+23 249999999999999995805696 64741033635463555000000000 34f086f3b33b68000000 + 1.555555556e+23 155555555555555540060864.512 1.556e+23 155555555555555546234880 40741273760221750600000000 20f0aefe091f46000000 + 1e+24 1000000000000000013287555.072 1.000e+24 999999999999999983222784 323604157166316664000000000 d3c21bcecceda0000000 + 1.444444444e+24 1444444444444444433095589.888 1.444e+24 1444444444444444420210688 461676766000271004000000000 131df7d800b9020000000 + 1.5e+24 1499999999999999882492379.136 1.500e+24 1499999999999999974834176 475506246661466216000000000 13da329b6336470000000 + 2.5e+24 2499999999999999895779934.208 2.500e+24 2499999999999999689621504 1021312426050005100000000000 211654585005200000000 + 1.555555556e+24 1555555555555555606767075.328 1.556e+24 1555555555555555529457664 511315527542663430000000000 14966d5ec5b38c0000000 + 1e+25 10000000000000001782142992.384 1.000e+25 10000000000000000905969664 4105452130240024420000000000 845951614014880000000 + 1.444444444e+25 14444444444444444330955898.880 1.444e+25 14444444444444445275848704 5762565634003472060000000000 bf2bae70073a180000000 + 1.5e+25 15000000000000002673214488.576 1.500e+25 15000000000000002432696320 6150277204360036640000000000 c685fa11e01ed00000000 + 2.5e+25 25000000000000002256334225.408 2.500e+25 25000000000000001191182336 12255751334620063240000000000 14adf4b732033500000000 + 1.555555556e+25 15555555555555556617426567.168 1.556e+25 15555555555555557442060288 6336010554734403400000000000 cde045b3b903800000000 + 1e+26 100000000000000009025336901.632 1.000e+26 100000000000000004764729344 51267645563100315200000000000 52b7d2dcc80cd400000000 + 1.444444444e+26 144444444444444465299791544.320 1.444e+26 144444444444444457053454336 73573232030044105000000000000 777b4d0604845000000000 + 1.5e+26 150000000000000013538005352.448 1.500e+26 150000000000000015737028608 76023570454540464000000000000 7c13bc4b2c134000000000 + 2.5e+26 250000000000000004971156209.664 2.500e+26 250000000000000003321888768 147313436237641001000000000000 cecb8f27f4201000000000 + 1.555555556e+26 155555555555555579368405204.992 1.556e+26 155555555555555574420602880 100254127101235043000000000000 80ac2b9053a23000000000 + 1e+27 1000000000000000019884624838.656 1.000e+27 1000000000000000013287555072 635456171177204004000000000000 33b2e3c9fd0804000000000 + 1.444444444e+27 1444444444444444441891682910.208 1.444e+27 1444444444444444433095589888 1125321004360551260000000000000 4aad1023c2d2b0000000000 + 1.5e+27 1500000000000000170564425613.312 1.500e+27 1500000000000000157370286080 1154305265676706010000000000000 4d8c55aefb8c08000000000 + 2.5e+27 2499999999999999908974073741.312 2.500e+27 2499999999999999895779934208 2011763457076112010000000000000 813f3978f89408000000000 + 1.555555556e+27 1555555555555555617762191605.760 1.556e+27 1555555555555555606767075328 1203271547215042534000000000000 506b9b3a34455c000000000 + 1e+28 9999999999999999635896294965.248 1.000e+28 9999999999999999583119736832 10047716274370450040000000000000 204fce5e3e25020000000000 + 1.444444444e+28 14444444444444444418916829102.080 1.444e+28 14444444444444444330955898880 13526052054547035340000000000000 2eac2a1659c3ae0000000000 + 1.5e+28 14999999999999999453844442447.872 1.500e+28 15000000000000000474191233024 14073665432564674100000000000000 3077b58d5d37840000000000 + 2.5e+28 24999999999999996837940923727.872 2.500e+28 24999999999999997858287714304 24143603727155344100000000000000 50c783eb9b5c840000000000 + 1.555555556e+28 15555555555555554488772055793.664 1.556e+28 15555555555555554418403311616 14441501010602532600000000000000 3243410460ab580000000000 + 1e+29 99999999999999987351763694911.488 1.000e+29 99999999999999991433150857216 120617017534665620400000000000000 1431e0fae6d72100000000000 + 1.444444444e+29 144444444444444426174769781538.816 1.444e+29 144444444444444430115419455488 164534644677006446000000000000000 1d2b9a4df81a4c00000000000 + 1.5e+29 149999999999999999042044051849.216 1.500e+29 149999999999999995945819308032 171126427413220531000000000000000 1e4ad1785a42b200000000000 + 2.5e+29 249999999999999986393807746760.704 2.500e+29 249999999999999969786784120832 311745447150106351000000000000000 327cb2734119d200000000000 + 1.555555556e+29 155555555555555535880521303195.648 1.556e+29 155555555555555544184033116160 175520212127432613400000000000000 1f6a08a2bc6b1700000000000 + 1e+30 1000000000000000089690419062898.688 1.000e+30 1000000000000000019884624838656 1447626234640431650000000000000000 c9f2c9cd04675000000000000 + 1.444444444e+30 1444444444444444333805291853316.096 1.444e+30 1444444444444444441891682910208 2216640160566101600000000000000000 123b4070bb1070000000000000 + 1.5e+30 1500000000000000206593222632275.968 1.500e+30 1500000000000000170564425613312 2273541353160646600000000000000000 12eec2eb3869b0000000000000 + 2.5e+30 2499999999999999863938077467607.040 2.500e+30 2499999999999999908974073741312 3743367610021300440000000000000000 1f8def8808b024000000000000 + 1.555555556e+30 1555555555555555502920401107812.352 1.556e+30 1555555555555555617762191605760 2350442545553413570000000000000000 13a24565b5c2ef000000000000 + 0.0 0.000 0.000e0 0 0 0 + -1e-12 -0.000 -1.000e-12 0 0 0 +-1.444444444e-12 -0.000 -1.444e-12 0 0 0 + -1.5e-12 -0.000 -1.500e-12 0 0 0 + -2.5e-12 -0.000 -2.500e-12 0 0 0 +-1.555555556e-12 -0.000 -1.556e-12 0 0 0 + -1e-11 -0.000 -1.000e-11 0 0 0 +-1.444444444e-11 -0.000 -1.444e-11 0 0 0 + -1.5e-11 -0.000 -1.500e-11 0 0 0 + -2.5e-11 -0.000 -2.500e-11 0 0 0 +-1.555555556e-11 -0.000 -1.556e-11 0 0 0 + -1e-10 -0.000 -1.000e-10 0 0 0 +-1.444444444e-10 -0.000 -1.444e-10 0 0 0 + -1.5e-10 -0.000 -1.500e-10 0 0 0 + -2.5e-10 -0.000 -2.500e-10 0 0 0 +-1.555555556e-10 -0.000 -1.556e-10 0 0 0 + -1e-09 -0.000 -1.000e-9 0 0 0 +-1.444444444e-09 -0.000 -1.444e-9 0 0 0 + -1.5e-09 -0.000 -1.500e-9 0 0 0 + -2.5e-09 -0.000 -2.500e-9 0 0 0 +-1.555555556e-09 -0.000 -1.556e-9 0 0 0 + -1e-08 -0.000 -1.000e-8 0 0 0 +-1.444444444e-08 -0.000 -1.444e-8 0 0 0 + -1.5e-08 -0.000 -1.500e-8 0 0 0 + -2.5e-08 -0.000 -2.500e-8 0 0 0 +-1.555555556e-08 -0.000 -1.556e-8 0 0 0 + -1e-07 -0.000 -1.000e-7 0 0 0 +-1.444444444e-07 -0.000 -1.444e-7 0 0 0 + -1.5e-07 -0.000 -1.500e-7 0 0 0 + -2.5e-07 -0.000 -2.500e-7 0 0 0 +-1.555555556e-07 -0.000 -1.556e-7 0 0 0 + -1e-06 -0.000 -1.000e-6 0 0 0 +-1.444444444e-06 -0.000 -1.444e-6 0 0 0 + -1.5e-06 -0.000 -1.500e-6 0 0 0 + -2.5e-06 -0.000 -2.500e-6 0 0 0 +-1.555555556e-06 -0.000 -1.556e-6 0 0 0 + -1e-05 -0.000 -1.000e-5 0 0 0 +-1.444444444e-05 -0.000 -1.444e-5 0 0 0 + -1.5e-05 -0.000 -1.500e-5 0 0 0 + -2.5e-05 -0.000 -2.500e-5 0 0 0 +-1.555555556e-05 -0.000 -1.556e-5 0 0 0 + -0.0001 -0.000 -1.000e-4 0 0 0 +-0.0001444444444 -0.000 -1.444e-4 0 0 0 + -0.00015 -0.000 -1.500e-4 0 0 0 + -0.00025 -0.000 -2.500e-4 0 0 0 +-0.0001555555556 -0.000 -1.556e-4 0 0 0 + -0.001 -0.001 -1.000e-3 0 0 0 + -0.001444444444 -0.001 -1.444e-3 0 0 0 + -0.0015 -0.002 -1.500e-3 0 0 0 + -0.0025 -0.003 -2.500e-3 0 0 0 + -0.001555555556 -0.002 -1.556e-3 0 0 0 + -0.01 -0.010 -1.000e-2 0 0 0 + -0.01444444444 -0.014 -1.444e-2 0 0 0 + -0.015 -0.015 -1.500e-2 0 0 0 + -0.025 -0.025 -2.500e-2 0 0 0 + -0.01555555556 -0.016 -1.556e-2 0 0 0 + -0.1 -0.100 -1.000e-1 0 0 0 + -0.1444444444 -0.144 -1.444e-1 0 0 0 + -0.15 -0.150 -1.500e-1 0 0 0 + -0.25 -0.250 -2.500e-1 0 0 0 + -0.1555555556 -0.156 -1.556e-1 0 0 0 + -1.0 -1.000 -1.000e0 -1 37777777777 ffffffff + -1.444444444 -1.444 -1.444e0 -1 37777777777 ffffffff + -1.5 -1.500 -1.500e0 -1 37777777777 ffffffff + -2.5 -2.500 -2.500e0 -2 37777777776 fffffffe + -1.555555556 -1.556 -1.556e0 -1 37777777777 ffffffff + -10.0 -10.000 -1.000e+1 -10 37777777766 fffffff6 + -14.44444444 -14.444 -1.444e+1 -14 37777777762 fffffff2 + -15.0 -15.000 -1.500e+1 -15 37777777761 fffffff1 + -25.0 -25.000 -2.500e+1 -25 37777777747 ffffffe7 + -15.55555556 -15.556 -1.556e+1 -15 37777777761 fffffff1 + -100.0 -100.000 -1.000e+2 -100 37777777634 ffffff9c + -144.4444444 -144.444 -1.444e+2 -144 37777777560 ffffff70 + -150.0 -150.000 -1.500e+2 -150 37777777552 ffffff6a + -250.0 -250.000 -2.500e+2 -250 37777777406 ffffff06 + -155.5555556 -155.556 -1.556e+2 -155 37777777545 ffffff65 + -1000.0 -1000.000 -1.000e+3 -1000 37777776030 fffffc18 + -1444.444444 -1444.444 -1.444e+3 -1444 37777775134 fffffa5c + -1500.0 -1500.000 -1.500e+3 -1500 37777775044 fffffa24 + -2500.0 -2500.000 -2.500e+3 -2500 37777773074 fffff63c + -1555.555556 -1555.556 -1.556e+3 -1555 37777774755 fffff9ed + -10000.0 -10000.000 -1.000e+4 -10000 37777754360 ffffd8f0 + -14444.44444 -14444.444 -1.444e+4 -14444 37777743624 ffffc794 + -15000.0 -15000.000 -1.500e+4 -15000 37777742550 ffffc568 + -25000.0 -25000.000 -2.500e+4 -25000 37777717130 ffff9e58 + -15555.55556 -15555.556 -1.556e+4 -15555 37777741475 ffffc33d + -100000.0 -100000.000 -1.000e+5 -100000 37777474540 fffe7960 + -144444.4444 -144444.444 -1.444e+5 -144444 37777345704 fffdcbc4 + -150000.0 -150000.000 -1.500e+5 -150000 37777333020 fffdb610 + -250000.0 -250000.000 -2.500e+5 -250000 37777027560 fffc2f70 + -155555.5556 -155555.556 -1.556e+5 -155555 37777320135 fffda05d + -1000000.0 -1000000.000 -1.000e+6 -1000000 37774136700 fff0bdc0 + -1444444.444 -1444444.444 -1.444e+6 -1444444 37772372644 ffe9f5a4 + -1500000.0 -1500000.000 -1.500e+6 -1500000 37772216240 ffe91ca0 + -2500000.0 -2500000.000 -2.500e+6 -2500000 37766355140 ffd9da60 + -1555555.556 -1555555.556 -1.556e+6 -1555555 37772041635 ffe8439d + -10000000.0 -10000000.000 -1.000e+7 -10000000 37731664600 ff676980 + -14444444.44 -14444444.444 -1.444e+7 -14444444 37710714144 ff239864 + -15000000.0 -15000000.000 -1.500e+7 -15000000 37706617100 ff1b1e40 + -25000000.0 -25000000.000 -2.500e+7 -25000000 37640503700 fe8287c0 + -15555555.56 -15555555.556 -1.556e+7 -15555555 37704522035 ff12a41d + -100000000.0 -100000000.000 -1.000e+8 -100000000 37202417400 fa0a1f00 + -144444444.4 -144444444.444 -1.444e+8 -144444444 36730771744 f763f3e4 + -150000000.0 -150000000.000 -1.500e+8 -150000000 36703627200 f70f2e80 + -250000000.0 -250000000.000 -2.500e+8 -250000000 36106246600 f1194d80 + -155555555.6 -155555555.556 -1.556e+8 -155555555 36656464435 f6ba691d + -1000000000.0 -1000000000.000 -1.000e+9 -1000000000 30431233000 c4653600 + -1444444444.0 -1444444444.444 -1.444e+9 -1444444444 25171703344 a9e786e4 + -1500000000.0 -1500000000.000 -1.500e+9 -1500000000 24645750400 a697d100 + -2500000000.0 -2500000000.000 -2.500e+9 -2500000000 55277203400 6afd0700 + -1555555556.0 -1555555555.556 -1.556e+9 -1555555555 24322015435 a3481b1d + -1e+10 -10000000000.000 -1.000e+10 -10000000000 665375016000 dabf41c00 +-1.444444444e+10 -14444444444.444 -1.444e+10 -14444444444 624302642344 ca30b44e4 + -1.5e+10 -15000000000.000 -1.500e+10 -15000000000 620173425000 c81ee2a00 + -2.5e+10 -25000000000.000 -2.500e+10 -25000000000 505570443000 a2de24600 +-1.555555556e+10 -15555555555.556 -1.556e+10 -15555555555 614064207435 c60d10f1d + -1e+11 -100000000000.000 -1.000e+11 -100000000000 6426742214000 e8b7891800 +-1.444444444e+11 -144444444444.444 -1.444e+11 -144444444444 5713634130344 de5e70b0e4 + -1.5e+11 -150000000000.000 -1.500e+11 -150000000000 5642323322000 dd134da400 + -2.5e+11 -250000000000.000 -2.500e+11 -250000000000 4271265536000 c5cad6bc00 +-1.555555556e+11 -155555555555.556 -1.556e+11 -155555555555 5571012513435 dbc82a971d + -1e+12 -1000000000000.000 -1.000e+12 -1000000000000 61345326570000 172b5af000 +-1.444444444e+12 -1444444444444.444 -1.444e+12 -1444444444444 52766031564344 eafb066e8e4 + -1.5e+12 -1500000000000.000 -1.500e+12 -1500000000000 52130102064000 ea2c1086800 + -2.5e+12 -2500000000000.000 -2.500e+12 -2500000000000 33475430654000 db9ec635800 +-1.555555556e+12 -1555555555555.556 -1.556e+12 -1555555555555 51272152363435 e95d1a9e71d + -1e+13 -10000000000000.000 -1.000e+13 -10000000000000 556366143260000 6e7b18d6000 +-1.444444444e+13 -14444444444444.444 -1.444e+13 -14444444444444 455634401214344 2dce40518e4 + -1.5e+13 -15000000000000.000 -1.500e+13 -15000000000000 445561225010000 25b8a541000 + -2.5e+13 -25000000000000.000 -2.500e+13 -25000000000000 224147370270000 e9433be17000 +-1.555555556e+13 -15555555555555.556 -1.556e+13 -15555555555555 435506050603435 1da30a3071d + -1e+14 -100000000000000.000 -1.000e+14 -100000000000000 5120635741340000 a50cef85c000 +-1.444444444e+14 -144444444444444.448 -1.444e+14 -144444444444444 3712035014574344 7ca0e832f8e4 + -1.5e+14 -150000000000000.000 -1.500e+14 -150000000000000 3571154722120000 77936748a000 + -2.5e+14 -250000000000000.000 -2.500e+14 -250000000000000 0712012663460000 1ca056ce6000 +-1.555555556e+14 -155555555555555.552 -1.556e+14 -155555555555555 3450274627443435 7285e65e471d + -1e+15 -1000000000000000.000 -1.000e+15 -1000000000000000 43450053316300000 c72815b398000 +-1.444444444e+15 -1444444444444444.416 -1.444e+15 -1444444444444444 26744442177334344 ade4911fdb8e4 + -1.5e+15 -1500000000000000.000 -1.500e+15 -1500000000000000 25274101065440000 aabc208d64000 + -2.5e+15 -2500000000000000.000 -2.500e+15 -2500000000000000 670744154403740000 71e43640fc000 +-1.555555556e+15 -1555555555555555.584 -1.556e+15 -1555555555555555 23623537753543435 a793affaec71d + -1e+16 -10000000000000000.000 -1.000e+16 -10000000000000000 343620662017600000 dc790d903f0000 +-1.444444444e+16 -14444444444444444.672 -1.444e+16 -14444444444444444 145355526372234344 ccaedab3e938e4 + -1.5e+16 -15000000000000000.000 -1.500e+16 -15000000000000000 125531213027500000 cab594585e8000 + -2.5e+16 -25000000000000000.000 -2.500e+16 -25000000000000000 6471352075047300000 a72ea1e89d8000 +-1.555555556e+16 -15555555555555555.328 -1.556e+16 -15555555555555556 105704677464743434 c8bc4dfcd3c71c + -1e+17 -100000000000000000.000 -1.000e+17 -100000000000000000 2345650364235400000 e9cba87a2760000 +-1.444444444e+17 -144444444444444442.624 -1.444e+17 -144444444444444448 67766510540707034340 dfed48b071c38e0 + -1.5e+17 -150000000000000000.000 -1.500e+17 -150000000000000000 67530574556354200000 deb17cb73b10000 + -2.5e+17 -250000000000000000.000 -2.500e+17 -250000000000000000 62076445142611600000 c87d25316270000 +-1.555555556e+17 -155555555555555540.992 -1.556e+17 -155555555555555552 67272660574021343440 dd75b0be045c720 + -1e+18 -1000000000000000000.000 -1.000e+18 -1000000000000000000 10372224613047000000 21f494c589c0000 +-1.444444444e+18 -1444444444444444327.936 -1.444e+18 -1444444444444444416 657642326710706434400 ebf44d6e471a3900 + -1.5e+18 -1500000000000000000.000 -1.500e+18 -1500000000000000000 654567337120472400000 eb2eedf284ea0000 + -2.5e+18 -2500000000000000000.000 -2.500e+18 -2500000000000000000 565161563733541400000 dd4e373edd860000 +-1.555555556e+18 -1555555555555555672.064 -1.556e+18 -1555555555555555584 651514347330256343400 ea698e76c2b9c700 + -1e+19 -10000000000000000000.000 -1.000e+19 -10000000000000000000 6724706717556606000000 7538dcfb76180000 +-1.444444444e+19 -14444444444444445376.512 -1.444e+19 -14444444444444444672 6336130144730701434000 378b064ec7063800 + -1.5e+19 -15000000000000000000.000 -1.500e+19 -15000000000000000000 6277252267446111000000 2fd54b7931240000 + -2.5e+19 -24999999999999997902.848 -2.500e+19 -25000000000000000000 5224161207224717000000 ea50e2874a73c0000 +-1.555555556e+19 -15555555555555554623.488 -1.556e+19 -15555555555555555328 6240374412163320344000 281f90a39b41c800 + -1e+20 -99999999999999991611.392 -1.000e+20 -100000000000000000000 65120705035123474000000 a9438a1d29cf00000 +-1.444444444e+20 -144444444444444445376.512 -1.444e+20 -144444444444444442624 60255561761170617440000 82b6e3f13c63e4000 + -1.5e+20 -150000000000000004194.304 -1.500e+20 -150000000000000000000 57571247453575332000000 7de54f2bbeb680000 + -2.5e+20 -249999999999999995805.696 -2.500e+20 -250000000000000000000 44712154510721026000000 2728d948e88580000 +-1.555555556e+20 -155555555555555579789.312 -1.556e+20 -155555555555555573760 57104735146202044300000 7913ba66410918000 + -1e+21 -999999999999999983222.784 -1.000e+21 -1000000000000000000000 623450662443504130000000 c9ca36523a21600000 +-1.444444444e+21 -1444444444444444420210.688 -1.444e+21 -1444444444444444327936 543311163554267634000000 b1b24e76c5be700000 + -1.5e+21 -1499999999999999974834.176 -1.500e+21 -1500000000000000000000 535275213665346204000000 aeaf517b5732100000 + -2.5e+21 -2500000000000000226492.416 -2.500e+21 -2500000000000000000000 360746076331052334000000 787987cd9153700000 +-1.555555556e+21 -1555555555555555797893.120 -1.556e+21 -1555555555555555672064 527261243776424554000000 abac547fe8a5b00000 + -1e+22 -10000000000000000905969.664 -1.000e+22 -10000000000000000000000 5703630371544251560000000 de1e61f36454dc00000 +-1.444444444e+22 -14444444444444443128365.056 -1.444e+22 -14444444444444443279360 4741734205073456030000000 cf0f710a3b970600000 + -1.5e+22 -15000000000000000285212.672 -1.500e+22 -15000000000000000000000 4645544566426376450000000 cd2d92ed167f4a00000 + -2.5e+22 -24999999999999996896215.040 -2.500e+22 -24999999999999997902848 2551375160172650240000000 ab4bf4e07ad42800000 +-1.555555556e+22 -15555555555555557442060.288 -1.556e+22 -15555555555555556720640 4551355147761317070000000 cb4bb4cff1678e00000 + -1e+23 -99999999999999987584860.160 -1.000e+23 -99999999999999991611392 52645764700753241200000000 ead2fd381eb50a000000 +-1.444444444e+23 -144444444444444422693715.968 -1.444e+23 -144444444444444428599296 41323232463123714400000000 e169a6a6653e64000000 + -1.5e+23 -149999999999999981377290.240 -1.500e+23 -149999999999999987417088 40170757241340761700000000 e03c7bd42e0f8f000000 + -2.5e+23 -250000000000000003321888.768 -2.500e+23 -249999999999999995805696 13036744142314223000000000 cb0f790c4cc498000000 +-1.555555556e+23 -155555555555555540060864.512 -1.556e+23 -155555555555555546234880 37036504017556027200000000 df0f5101f6e0ba000000 + -1e+24 -1000000000000000013287555.072 -1.000e+24 -999999999999999983222784 454173620611461114000000000 2c3de431331260000000 +-1.444444444e+24 -1444444444444444433095589.888 -1.444e+24 -1444444444444444420210688 316101011777506774000000000 ece20827ff46fe0000000 + -1.5e+24 -1499999999999999882492379.136 -1.500e+24 -1499999999999999974834176 302271531116311562000000000 ec25cd649cc9b90000000 + -2.5e+24 -2499999999999999895779934.208 -2.500e+24 -2499999999999999689621504 6756465351727772700000000000 dee9aba7affae00000000 +-1.555555556e+24 -1555555555555555606767075.328 -1.556e+24 -1555555555555555529457664 266462250235114350000000000 eb6992a13a4c740000000 + -1e+25 -10000000000000001782142992.384 -1.000e+25 -10000000000000000905969664 3672325647537753360000000000 7ba6ae9ebfeb780000000 +-1.444444444e+25 -14444444444444444330955898.880 -1.444e+25 -14444444444444445275848704 2015212143774305720000000000 40d4518ff8c5e80000000 + -1.5e+25 -15000000000000002673214488.576 -1.500e+25 -15000000000000002432696320 1627500573417741140000000000 397a05ee1fe1300000000 + -2.5e+25 -25000000000000002256334225.408 -2.500e+25 -25000000000000001191182336 65522026443157714540000000000 eb520b48cdfccb00000000 +-1.555555556e+25 -15555555555555556617426567.168 -1.556e+25 -15555555555555557442060288 1441767223043374400000000000 321fba4c46fc800000000 + -1e+26 -100000000000000009025336901.632 -1.000e+26 -100000000000000004764729344 26510132214677462600000000000 ad482d2337f32c00000000 +-1.444444444e+26 -144444444444444465299791544.320 -1.444e+26 -144444444444444457053454336 04204545747733673000000000000 8884b2f9fb7bb000000000 + -1.5e+26 -150000000000000013538005352.448 -1.500e+26 -150000000000000015737028608 01754207323237314000000000000 83ec43b4d3ecc000000000 + -2.5e+26 -250000000000000004971156209.664 -2.500e+26 -250000000000000003321888768 630464341540136777000000000000 313470d80bdff000000000 +-1.555555556e+26 -155555555555555579368405204.992 -1.556e+26 -155555555555555574420602880 677523650676542735000000000000 7f53d46fac5dd000000000 + -1e+27 -1000000000000000019884624838.656 -1.000e+27 -1000000000000000013287555072 142321606600573774000000000000 cc4d1c3602f7fc000000000 +-1.444444444e+27 -1444444444444444441891682910.208 -1.444e+27 -1444444444444444433095589888 6652456773417226520000000000000 b552efdc3d2d50000000000 + -1.5e+27 -1500000000000000170564425613.312 -1.500e+27 -1500000000000000157370286080 6623472512101071770000000000000 b273aa510473f8000000000 + -2.5e+27 -2499999999999999908974073741.312 -2.500e+27 -2499999999999999895779934208 5766014320701665770000000000000 7ec0c687076bf8000000000 +-1.555555556e+27 -1555555555555555617762191605.760 -1.556e+27 -1555555555555555606767075328 6574506230562735244000000000000 af9464c5cbbaa4000000000 + -1e+28 -9999999999999999635896294965.248 -1.000e+28 -9999999999999999583119736832 67730061503407327740000000000000 dfb031a1c1dafe0000000000 +-1.444444444e+28 -14444444444444444418916829102.080 -1.444e+28 -14444444444444444330955898880 64251725723230742440000000000000 d153d5e9a63c520000000000 + -1.5e+28 -14999999999999999453844442447.872 -1.500e+28 -15000000000000000474191233024 63704112345213103700000000000000 cf884a72a2c87c0000000000 + -2.5e+28 -24999999999999996837940923727.872 -2.500e+28 -24999999999999997858287714304 53634174050622433700000000000000 af387c1464a37c0000000000 +-1.555555556e+28 -15555555555555554488772055793.664 -1.556e+28 -15555555555555554418403311616 63336276767175245200000000000000 cdbcbefb9f54a80000000000 + -1e+29 -99999999999999987351763694911.488 -1.000e+29 -99999999999999991433150857216 657160760243112157400000000000000 ebce1f051928df00000000000 +-1.444444444e+29 -144444444444444426174769781538.816 -1.444e+29 -144444444444444430115419455488 613243133100771332000000000000000 e2d465b207e5b400000000000 + -1.5e+29 -149999999999999999042044051849.216 -1.500e+29 -149999999999999995945819308032 606651350364557247000000000000000 e1b52e87a5bd4e00000000000 + -2.5e+29 -249999999999999986393807746760.704 -2.500e+29 -249999999999999969786784120832 466032330627671427000000000000000 cd834d8cbee62e00000000000 +-1.555555556e+29 -155555555555555535880521303195.648 -1.556e+29 -155555555555555544184033116160 602257565650345164400000000000000 e095f75d4394e900000000000 + -1e+30 -1000000000000000089690419062898.688 -1.000e+30 -1000000000000000019884624838656 6330151543137346130000000000000000 360d3632fb98b000000000000 +-1.444444444e+30 -1444444444444444333805291853316.096 -1.444e+30 -1444444444444444441891682910208 5561137617211676200000000000000000 edc4bf8f44ef90000000000000 + -1.5e+30 -1500000000000000206593222632275.968 -1.500e+30 -1500000000000000170564425613312 5504236424617131200000000000000000 ed113d14c79650000000000000 + -2.5e+30 -2499999999999999863938077467607.040 -2.500e+30 -2499999999999999908974073741312 4034410167756477340000000000000000 e0721077f74fdc000000000000 +-1.555555556e+30 -1555555555555555502920401107812.352 -1.556e+30 -1555555555555555617762191605760 5427335232224364210000000000000000 ec5dba9a4a3d11000000000000 |