summaryrefslogtreecommitdiff
path: root/ipl/cfuncs
diff options
context:
space:
mode:
Diffstat (limited to 'ipl/cfuncs')
-rw-r--r--ipl/cfuncs/Makefile43
-rw-r--r--ipl/cfuncs/README15
-rw-r--r--ipl/cfuncs/bitcount.c45
-rw-r--r--ipl/cfuncs/files.c57
-rw-r--r--ipl/cfuncs/fpoll.c99
-rw-r--r--ipl/cfuncs/icall.h218
-rw-r--r--ipl/cfuncs/ilists.c121
-rw-r--r--ipl/cfuncs/internal.c79
-rw-r--r--ipl/cfuncs/lgconv.c181
-rwxr-xr-xipl/cfuncs/mkfunc.sh73
-rwxr-xr-xipl/cfuncs/mklib.sh32
-rw-r--r--ipl/cfuncs/osf.c80
-rw-r--r--ipl/cfuncs/pack.c261
-rw-r--r--ipl/cfuncs/ppm.c581
-rw-r--r--ipl/cfuncs/process.c73
-rw-r--r--ipl/cfuncs/tconnect.c96
16 files changed, 2054 insertions, 0 deletions
diff --git a/ipl/cfuncs/Makefile b/ipl/cfuncs/Makefile
new file mode 100644
index 0000000..d8b1ba2
--- /dev/null
+++ b/ipl/cfuncs/Makefile
@@ -0,0 +1,43 @@
+# Makefile for the dynamically loaded C function library.
+#
+# If building with the compiler (instead of the interpreter)
+# use the "-fs" option to avoid problems.
+
+
+include ../../Makedefs
+
+ICONT = icont
+IFLAGS = -us
+
+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 \
+ pack.o ppm.o process.o tconnect.o
+CSRC = $(FUNCS:.o=.c)
+
+
+default: cfunc.u2 $(FUNCLIB)
+
+
+# library
+
+$(FUNCLIB): $(FUNCS) mklib.sh
+ CC="$(CC)" CFLAGS="$(CFLAGS)" sh mklib.sh $(FUNCLIB) $(FUNCS)
+$(FUNCS): icall.h
+
+
+# Icon interface
+
+cfunc.u2: cfunc.icn
+ $(ICONT) $(IFLAGS) -c cfunc.icn
+cfunc.icn: $(CSRC) mkfunc.sh
+ sh mkfunc.sh $(FUNCLIB) $(FUNCS) >cfunc.icn
+
+
+# cleanup
+
+clean Clean:
+ rm -f $(FUNCLIB) *.o *.u? *.so so_locations cfunc.icn
diff --git a/ipl/cfuncs/README b/ipl/cfuncs/README
new file mode 100644
index 0000000..d30a658
--- /dev/null
+++ b/ipl/cfuncs/README
@@ -0,0 +1,15 @@
+C Interface Functions for Icon
+
+This directory contains C functions that can be called from Icon on
+systems supporting dynamic loading via dlopen(3). These systems include
+SunOS, Solaris, OSF/1, Irix, and Linux.
+
+To see what's available, look at the comments in the .c files. To use
+a C function, just use "link cfunc" and call the function by name.
+
+The C functions are loaded at runtime from a library file "libcfunc.so",
+which is found automatically in the Icon binary directory. This can be
+be overridden by setting the FPATH environment variable to a search path.
+
+To build the library, run "make". This process also builds "cfunc.icn",
+the file of interface procedures that actually load the C functions.
diff --git a/ipl/cfuncs/bitcount.c b/ipl/cfuncs/bitcount.c
new file mode 100644
index 0000000..c6a5be6
--- /dev/null
+++ b/ipl/cfuncs/bitcount.c
@@ -0,0 +1,45 @@
+/*
+############################################################################
+#
+# File: bitcount.c
+#
+# Subject: Function to count bits in an integer
+#
+# Author: Gregg M. Townsend
+#
+# Date: April 9, 1996
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# bitcount(i) returns the number of bits that are set in the integer i.
+# It works only for "normal" integers, not large integers.
+#
+############################################################################
+#
+# Requires: Dynamic loading
+#
+############################################################################
+*/
+
+#include "icall.h"
+
+int bitcount(int argc, descriptor *argv) /*: count bits in an integer */
+ {
+ unsigned long v;
+ int n;
+
+ ArgInteger(1); /* validate type */
+
+ v = IntegerVal(argv[1]); /* get value as unsigned long */
+ n = 0;
+ while (v != 0) { /* while more bits to count */
+ n += v & 1; /* check low-order bit */
+ v >>= 1; /* shift off with zero-fill */
+ }
+
+ RetInteger(n); /* return result */
+ }
diff --git a/ipl/cfuncs/files.c b/ipl/cfuncs/files.c
new file mode 100644
index 0000000..be9c17d
--- /dev/null
+++ b/ipl/cfuncs/files.c
@@ -0,0 +1,57 @@
+/*
+############################################################################
+#
+# File: files.c
+#
+# Subject: Functions to manipulate file attributes
+#
+# Author: Gregg M. Townsend
+#
+# Date: November 17, 2004
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# chmod(filename, mode) changes the file permission modes of a file to
+# those specified.
+#
+# umask(mask) sets the process "umask" to the specified value.
+# If mask is omitted, the current process mask is returned.
+#
+############################################################################
+#
+# Requires: UNIX, dynamic loading
+#
+############################################################################
+*/
+
+#include "icall.h"
+
+#include <sys/types.h>
+#include <sys/stat.h>
+
+int icon_chmod (int argc, descriptor argv[]) /*: change UNIX file permissions */
+ {
+ ArgString(1);
+ ArgInteger(2);
+ if (chmod(StringVal(argv[1]), IntegerVal(argv[2])) == 0)
+ RetNull();
+ else
+ Fail;
+ }
+
+int icon_umask (int argc, descriptor argv[]) /*: change UNIX permission mask */
+ {
+ int n;
+
+ if (argc == 0) {
+ umask(n = umask(0));
+ RetInteger(n);
+ }
+ ArgInteger(1);
+ umask(IntegerVal(argv[1]));
+ RetArg(1);
+ }
diff --git a/ipl/cfuncs/fpoll.c b/ipl/cfuncs/fpoll.c
new file mode 100644
index 0000000..f209e0d
--- /dev/null
+++ b/ipl/cfuncs/fpoll.c
@@ -0,0 +1,99 @@
+/*
+############################################################################
+#
+# File: fpoll.c
+#
+# Subject: Function to poll file for input
+#
+# Author: Gregg M. Townsend
+#
+# Date: November 27, 2001
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# fpoll(f, msec) waits until data is available for input from file f,
+# and then returns. It also returns when end-of-file is reached.
+# If msec is specified, and no data is available after waiting that
+# many milliseconds, then fpoll fails. If msec is omitted, fpoll
+# waits indefinitely.
+#
+############################################################################
+#
+# Requires: UNIX, dynamic loading
+#
+############################################################################
+*/
+
+#include <stdio.h>
+#include <sys/types.h>
+#include <sys/time.h>
+
+#include "icall.h"
+
+int fpoll(int argc, descriptor *argv) /*: await data from file */
+ {
+ FILE *f;
+ int msec, r;
+ fd_set fds;
+ struct timeval tv, *tvp;
+
+ /* check arguments */
+ if (argc < 1)
+ Error(105);
+ if ((IconType(argv[1]) != 'f') || (FileStat(argv[1]) & Fs_Window))
+ ArgError(1, 105);
+ if (!(FileStat(argv[1]) & Fs_Read))
+ ArgError(1, 212);
+ f = FileVal(argv[1]);
+
+ if (argc < 2)
+ msec = -1;
+ else {
+ ArgInteger(2);
+ msec = IntegerVal(argv[2]);
+ }
+
+ /* check for data already in buffer */
+ /* there's no legal way to do this in C; we cheat */
+#if defined(__GLIBC__) && defined(_STDIO_USES_IOSTREAM) /* new GCC library */
+ if (f->_IO_read_ptr < f->_IO_read_end)
+ RetArg(1);
+#elif defined(__GLIBC__) /* old GCC library */
+ if (f->__bufp < f->__get_limit)
+ RetArg(1);
+#elif defined(_FSTDIO) /* new BSD library */
+ if (f->_r > 0)
+ RetArg(1);
+#else /* old AT&T library */
+ if (f->_cnt > 0)
+ RetArg(1);
+#endif
+
+ /* set up select(2) structure */
+ FD_ZERO(&fds); /* clear file bits */
+ FD_SET(fileno(f), &fds); /* set bit of interest */
+
+ /* set up timeout and pointer */
+ if (msec < 0)
+ tvp = NULL;
+ else {
+ tv.tv_sec = msec / 1000;
+ tv.tv_usec = (msec % 1000) * 1000;
+ tvp = &tv;
+ }
+
+ /* poll the file using select(2) */
+ r = select(fileno(f) + 1, &fds, (fd_set*)NULL, (fd_set*)NULL, tvp);
+
+ if (r > 0)
+ RetArg(1); /* success */
+ else if (r == 0)
+ Fail; /* timeout */
+ else
+ ArgError(1, 214); /* I/O error */
+
+}
diff --git a/ipl/cfuncs/icall.h b/ipl/cfuncs/icall.h
new file mode 100644
index 0000000..2718dfa
--- /dev/null
+++ b/ipl/cfuncs/icall.h
@@ -0,0 +1,218 @@
+/*
+############################################################################
+#
+# File: icall.h
+#
+# Subject: Definitions for external C functions
+#
+# Author: Gregg M. Townsend
+#
+# Date: November 17, 2004
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# Contributor: Kostas Oikonomou
+#
+############################################################################
+#
+# These definitions assist in writing external C functions for use with
+# Version 9 of Icon.
+#
+############################################################################
+#
+# From Icon, loadfunc(libfile, funcname) loads a C function of the form
+# int func(int argc, descriptor argv[])
+# where "descriptor" is the structure type defined here. The C
+# function returns -1 to fail, 0 to succeed, or a positive integer
+# to report an error. Argv[1] through argv[argc] are the incoming
+# arguments; the return value on success (or the offending value
+# in case of error) is stored in argv[0].
+#
+# In the macro descriptions below, d is a descriptor value, typically
+# a member of the argv array. IMPORTANT: many macros assume that the
+# C function's parameters are named "argc" and "argv" as noted above.
+#
+############################################################################
+#
+# 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).
+# The character I indicates a large (multiprecision) integer.
+#
+# Only a few of these types (i, r, f, s) are easily manipulated in C.
+# Given that the type has been verified, the following macros return
+# the value of 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
+# FileVal(d) value of a file (type 'f') as a C FILE pointer
+# FileStat(d) status field of a file
+# StringVal(d) value of a string (type 's') as a C char pointer
+# (copied if necessary to add \0 for termination)
+#
+# StringAddr(d) address of possibly unterminated string
+# StringLen(d) length of string
+#
+# ListLen(d) length of list
+#
+# These macros check the type of an argument, converting if necessary,
+# and returning an error code if the argument is wrong:
+#
+# ArgInteger(i) check that argv[i] is an integer
+# 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
+#
+# Caveats:
+# Allocation failure is not detected.
+#
+############################################################################
+#
+# These macros return from the C function back to Icon code:
+#
+# Return return argv[0] (initially &null)
+# RetArg(i) return argv[i]
+# RetNull() return &null
+# RetInteger(i) return integer value i
+# RetReal(v) return real value v
+# RetFile(fp,status,name) return (newly opened) file
+# RetString(s) return null-terminated string s
+# RetStringN(s, n) return string s whose length is n
+# RetAlcString(s, n) return already-allocated string
+# RetConstString(s) return constant string s
+# RetConstStringN(s, n) return constant string s of length n
+# Fail return failure status
+# Error(n) return error code n
+# ArgError(i,n) return argv[i] as offending value for error n
+#
+############################################################################
+ */
+
+#include <stdio.h>
+#include <limits.h>
+
+#if INT_MAX == 32767
+#define WordSize 16
+#elif LONG_MAX == 2147483647L
+#define WordSize 32
+#else
+#define WordSize 64
+#endif
+
+#if WordSize <= 32
+#define F_Nqual 0x80000000 /* set if NOT string qualifier */
+#define F_Var 0x40000000 /* set if variable */
+#define F_Ptr 0x10000000 /* set if value field is pointer */
+#define F_Typecode 0x20000000 /* set if dword includes type code */
+#else
+#define F_Nqual 0x8000000000000000 /* set if NOT string qualifier */
+#define F_Var 0x4000000000000000 /* set if variable */
+#define F_Ptr 0x1000000000000000 /* set if value field is pointer */
+#define F_Typecode 0x2000000000000000 /* set if dword includes type code */
+#endif
+
+#define D_Typecode (F_Nqual | F_Typecode)
+
+#define T_Null 0 /* null value */
+#define T_Integer 1 /* integer */
+#define T_Real 3 /* real number */
+#define T_File 5 /* file, including window */
+
+#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 Fs_Read 0001 /* file open for reading */
+#define Fs_Write 0002 /* file open for writing */
+#define Fs_Pipe 0020 /* file is a [popen] pipe */
+#define Fs_Window 0400 /* file is a window */
+
+
+typedef long word;
+typedef struct { word dword, vword; } descriptor;
+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;
+
+
+char *alcstr(char *s, word len);
+realblock *alcreal(double v);
+fileblock *alcfile(FILE *fp, int stat, descriptor *name);
+int cnv_c_str(descriptor *s, descriptor *d);
+int cnv_int(descriptor *s, descriptor *d);
+int cnv_real(descriptor *s, descriptor *d);
+int cnv_str(descriptor *s, descriptor *d);
+double getdbl(descriptor *d);
+
+extern descriptor nulldesc; /* null descriptor */
+
+
+#define IconType(d) ((d).dword>=0 ? 's' : "niIrcfpRL.S.T.....C"[(d).dword&31])
+
+
+#define IntegerVal(d) ((d).vword)
+
+#define RealVal(d) getdbl(&(d))
+
+#define FileVal(d) (((fileblock *)((d).vword))->fp)
+#define FileStat(d) (((fileblock *)((d).vword))->stat)
+
+#define StringAddr(d) ((char *)(d).vword)
+#define StringLen(d) ((d).dword)
+
+#define StringVal(d) \
+(*(char*)((d).vword+(d).dword) ? cnv_c_str(&(d),&(d)) : 0, (char*)((d).vword))
+
+#define ListLen(d) (((listblock *)((d).vword))->size)
+
+
+#define ArgInteger(i) do { if (argc < (i)) Error(101); \
+if (!cnv_int(&argv[i],&argv[i])) ArgError(i,101); } while (0)
+
+#define ArgReal(i) do { if (argc < (i)) Error(102); \
+if (!cnv_real(&argv[i],&argv[i])) ArgError(i,102); } while (0)
+
+#define ArgString(i) do { if (argc < (i)) Error(103); \
+if (!cnv_str(&argv[i],&argv[i])) ArgError(i,103); } while (0)
+
+#define ArgList(i) \
+do {if (argc < (i)) Error(108); \
+if (IconType(argv[i]) != 'L') ArgError(i,108); } while(0)
+
+
+#define RetArg(i) return (argv[0] = argv[i], 0)
+
+#define RetNull() return (argv->dword = D_Null, argv->vword = 0)
+
+#define RetInteger(i) return (argv->dword = D_Integer, argv->vword = i, 0)
+
+#define RetReal(v) return (argv->dword=D_Real, argv->vword=(word)alcreal(v), 0)
+
+#define RetFile(fp,stat,name) \
+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 RetString(s) \
+do { word n = strlen(s); \
+argv->dword = n; argv->vword = (word)alcstr(s,n); return 0; } while (0)
+
+#define RetStringN(s,n) \
+do { argv->dword = n; argv->vword = (word)alcstr(s,n); return 0; } while (0)
+
+#define RetConstString(s) return (argv->dword=strlen(s), argv->vword=(word)s, 0)
+
+#define RetConstStringN(s,n) return (argv->dword=n, argv->vword=(word)s, 0)
+
+#define RetAlcString(s,n) return (argv->dword=n, argv->vword=(word)s, 0)
+
+
+#define Fail return -1
+#define Return return 0
+#define Error(n) return n
+#define ArgError(i,n) return (argv[0] = argv[i], n)
diff --git a/ipl/cfuncs/ilists.c b/ipl/cfuncs/ilists.c
new file mode 100644
index 0000000..73ed483
--- /dev/null
+++ b/ipl/cfuncs/ilists.c
@@ -0,0 +1,121 @@
+/*
+############################################################################
+#
+# File: ilists.c
+#
+# Subject: Icon-to-C interface for simple Icon lists
+#
+# Author: Kostas Oikonomou
+#
+# Date: April 26, 2002
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# This file provides three procedures for translating homogeneous
+# lists of integers, reals, or strings to C arrays:
+#
+# IListVal(d) returns an array of C ints.
+# RListVal(d) returns an array of C doubles.
+# SListVal(d) returns an array of C char pointers (char *).
+#
+############################################################################
+#
+# Here is an example of using this interface:
+#
+# 1. gcc -I/opt/icon/ipl/cfuncs -shared -fPIC -o llib.so l.c
+# where "l.c" is the C fragment below.
+#
+# #include "ilists.c"
+# int example(int argc, descriptor argv[])
+# {
+# int *ia;
+# double *ra;
+# char *(*sa);
+# int n; int i;
+# ArgList(1); n = ListLen(argv[1]);
+# ia = IListVal(argv[1]);
+# for (i=0; i<n; i++) printf("%i ", ia[i]); printf("\n");
+# ArgList(2); n = ListLen(argv[2]);
+# ra = RListVal(argv[2]);
+# for (i=0; i<n; i++) printf("%f ", ra[i]); printf("\n");
+# ArgList(3); n = ListLen(argv[3]);
+# printf("n = %i\n", n);
+# sa = SListVal(argv[3]);
+# for (i=0; i<n; i++) printf("%s ", sa[i]); printf("\n");
+# Return;
+# }
+#
+# 2. The Icon program that loads "example" from the library llib.so:
+#
+# procedure main()
+# local e, L1, L2, L3
+# e := loadfunc("./llib.so", "example")
+# L1 := []
+# every i := 1 to 5 do put(L1,10*i)
+# L3 := ["abcd","/a/b/c","%&*()","","|"]
+# e(L1,[1.1,2.2,-3.3,5.5555],L3)
+# end
+#
+############################################################################
+*/
+
+#include "icall.h"
+
+void cpslots(descriptor *, descriptor *, word, word);
+
+/*
+ * Given a descriptor of an Icon list of integers, this function returns
+ * a C array containing the integers.
+ *
+ * "cpslots" is defined in src/runtime/rstruct.r. Using cpslots() shortens the
+ * necessary code, and takes care of lists that have been constructed or
+ * modified by put() and get(), etc.
+ * The reference to "cpslots" is satisfied in iconx.
+ */
+
+int *IListVal(descriptor d) /*: make int[] array from list */
+ {
+ int *a;
+ int n = ListLen(d);
+ descriptor slot[n];
+ int i;
+
+ cpslots(&d,&slot[0],1,n+1);
+ a = (int *) calloc(n, sizeof(int));
+ if (!a) return NULL;
+ for (i=0; i<n; i++) a[i] = IntegerVal(slot[i]);
+ return &a[0];
+ }
+
+double *RListVal(descriptor d) /*: make double[] array from list */
+ {
+ double *a;
+ int n = ListLen(d);
+ descriptor slot[n];
+ int i;
+
+ cpslots(&d,&slot[0],1,n+1);
+ a = (double *) calloc(n, sizeof(double));
+ if (!a) return NULL;
+ for (i=0; i<n; i++) a[i] = RealVal(slot[i]);
+ return &a[0];
+ }
+
+char **SListVal(descriptor d) /*: make char*[] array from list */
+ {
+ char *(*a);
+ int n = ListLen(d);
+ descriptor slot[n];
+ int i;
+
+ cpslots(&d,&slot[0],1,n+1);
+ /* array of n pointers to chars */
+ a = (char **) calloc(n, sizeof(char *));
+ if (!a) return NULL;
+ for (i=0; i<n; i++) a[i] = StringVal(slot[i]);
+ return &a[0];
+ }
diff --git a/ipl/cfuncs/internal.c b/ipl/cfuncs/internal.c
new file mode 100644
index 0000000..4c18f1d
--- /dev/null
+++ b/ipl/cfuncs/internal.c
@@ -0,0 +1,79 @@
+/*
+############################################################################
+#
+# File: internal.c
+#
+# Subject: Functions to access Icon internals
+#
+# Author: Gregg M. Townsend
+#
+# Date: October 3, 1995
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# These functions provide some access to the internal machinery of the
+# Icon interpreter. Some knowledge of the interpreter is needed to use
+# these profitably; misuse can lead to memory violations.
+#
+# dword(x) return d-word of descriptor
+# vword(x) return v-word of descriptor
+# descriptor(d,v) construct descriptor from d-word and v-word
+# peek(addr,n) return contents of memory as n-character string
+# (if n is omitted, return Icon integer at addr)
+# spy(addr,n) return string pointer to memory, without copying
+#
+############################################################################
+#
+# Requires: Dynamic loading
+#
+############################################################################
+*/
+
+#include "icall.h"
+
+int dword(int argc, descriptor argv[]) /*: return descriptor d-word */
+ {
+ if (argc == 0)
+ Fail;
+ else
+ RetInteger(argv[1].dword);
+ }
+
+int vword(int argc, descriptor argv[]) /*: return descriptor v-word */
+ {
+ if (argc == 0)
+ Fail;
+ else
+ RetInteger(argv[1].vword);
+ }
+
+int icon_descriptor(int argc, descriptor argv[]) /*: construct descriptor */
+ {
+ ArgInteger(1);
+ ArgInteger(2);
+ argv[0].dword = argv[1].vword;
+ argv[0].vword = argv[2].vword;
+ Return;
+ }
+
+int peek(int argc, descriptor argv[]) /*: load value from memory */
+ {
+ ArgInteger(1);
+ if (argc > 1) {
+ ArgInteger(2);
+ RetStringN((void *)IntegerVal(argv[1]), IntegerVal(argv[2]));
+ }
+ else
+ RetInteger(*(word *)IntegerVal(argv[1]));
+ }
+
+int spy(int argc, descriptor argv[]) /*: create spy-port to memory */
+ {
+ ArgInteger(1);
+ ArgInteger(2);
+ RetConstStringN((void *)IntegerVal(argv[1]), IntegerVal(argv[2]));
+ }
diff --git a/ipl/cfuncs/lgconv.c b/ipl/cfuncs/lgconv.c
new file mode 100644
index 0000000..6d12162
--- /dev/null
+++ b/ipl/cfuncs/lgconv.c
@@ -0,0 +1,181 @@
+/*
+############################################################################
+#
+# File: lgconv.c
+#
+# Subject: Function to convert large integer to string
+#
+# Author: Gregg M. Townsend
+#
+# Date: November 17, 1997
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# lgconv(I) converts a large integer into a string using a series of BCD
+# adds. (In contrast, the Icon built-in string() function accomplishes
+# the same conversion using a series of divisions by 10.)
+#
+# lgconv is typically 50% to 75% faster than string() on a Sun or Alpha.
+# For some reason it is as much as 125% SLOWER on a SGI 4/380.
+#
+# lgconv(I) works for all integer values of I. Small integers are
+# simply passed to string() for conversion.
+#
+############################################################################
+#
+# Requires: Dynamic loading
+#
+############################################################################
+*/
+
+#include "icall.h"
+#include <math.h>
+#include <string.h>
+
+static void bcdadd(unsigned long lside[], unsigned long rside[], int n);
+
+
+
+/* definitions copied from Icon source code */
+
+typedef unsigned int DIGIT;
+#define NB (WordSize / 2) /* bits per digit */
+#define B ((word)1 << NB) /* bignum radix */
+
+struct b_bignum { /* large integer block */
+ word title; /* T_Lrgint */
+ word blksize; /* block size */
+ word msd, lsd; /* most and least significant digits */
+ int sign; /* sign; 0 positive, 1 negative */
+ DIGIT digits[1]; /* digits */
+ };
+
+
+
+
+int lgconv(argc, argv) /*: convert large integer to string */
+int argc;
+descriptor *argv;
+ {
+#define BCDIGITS (2 * sizeof(long)) /* BCD digits per long */
+ int nbig, ndec, nbcd, nchr, bcdlen, i, j, n, t;
+ char tbuf[25], *o, *p;
+ struct b_bignum *big;
+ DIGIT d, *dgp;
+ char *out;
+ unsigned long b, *bp, *bcdbuf, *powbuf, *totbuf;
+
+ t = IconType(argv[1]);
+ if (t != 'I') { /* if not large integer */
+ ArgInteger(1); /* must be a small one */
+ sprintf(tbuf, "%ld", IntegerVal(argv[1]));
+ RetString(tbuf);
+ }
+
+ big = (struct b_bignum *) argv[1].vword; /* pointer to bignum struct */
+ nbig = big->lsd - big->msd + 1; /* number of bignum digits */
+ ndec = nbig * NB * 0.3010299956639812 + 1; /* number of decimal digits */
+ nbcd = ndec / BCDIGITS + 1; /* number of BCD longs */
+
+ /* allocate string space for computation and output */
+ nchr = sizeof(long) * (2 * nbcd + 1);
+ out = alcstr(NULL, nchr);
+ if (!out)
+ Error(306);
+
+ /* round up for proper alignment so we can overlay longword buffers */
+ n = sizeof(long) - (long)out % sizeof(long); /* adjustment needed */
+ out += n; /* increment address */
+ nchr -= n; /* decrement length */
+
+ /* allocate computation buffers to overlay output string */
+ bcdbuf = (unsigned long *) out; /* BCD buffer area */
+ bcdlen = 1; /* start with just one BCD wd */
+ totbuf = bcdbuf + nbcd - bcdlen; /* BCD version of bignum */
+ powbuf = totbuf + nbcd; /* BCD powers of two */
+
+ memset(bcdbuf, 0, 2 * nbcd * sizeof(long)); /* zero BCD buffers */
+ powbuf[bcdlen-1] = 1; /* init powbuf to 1 */
+
+ /* compute BCD equivalent of the bignum value */
+ dgp = &big->digits[big->lsd];
+ for (i = 0; i < nbig; i++) {
+ d = *dgp--;
+ for (j = NB; j; j--) {
+ if (d & 1) /* if bit is set in bignum */
+ bcdadd(totbuf, powbuf, bcdlen); /* add 2^n to totbuf */
+ d >>= 1;
+ bcdadd(powbuf, powbuf, bcdlen); /* double BCD power-of-two */
+ if (*powbuf >= (5LU << (WordSize-4))) {/* if too big to add */
+ bcdlen += 1; /* grow buffers */
+ powbuf -= 1;
+ totbuf -= 1;
+ }
+ }
+ }
+
+ /* convert BCD to decimal characters */
+ o = p = out + nchr;
+ bp = totbuf + bcdlen;
+ for (i = 0; i < bcdlen; i++) {
+ b = *--bp;
+ for (j = 0; j < BCDIGITS; j++) {
+ *--o = (b & 0xF) + '0';
+ b >>= 4;
+ }
+ }
+
+ /* trim leading zeroes, add sign, and return value */
+ while (*o == '0' && o < p - 1)
+ o++;
+ if (big->sign)
+ *--o = '-';
+ RetAlcString(o, p - o);
+ }
+
+
+
+/*
+ * bcdadd(lside,rside,n) -- compute lside += rside for n BCD longwords
+ *
+ * lside and rside are arrays of n unsigned longs holding BCD values,
+ * with MSB in the first longword. rside is added into lside in place.
+ */
+
+static void bcdadd(unsigned long lside[], unsigned long rside[], int n)
+{
+#define CSHIFT (WordSize - 4)
+#if WordSize == 64
+#define BIAS 0x6666666666666666u
+#define MASK 0xF0F0F0F0F0F0F0F0u
+#else
+#define BIAS 0x66666666u
+#define MASK 0xF0F0F0F0u
+#endif
+ unsigned long lword, rword, low, hgh, carry, icarry;
+
+ lside += n;
+ rside += n;
+ carry = 0;
+
+ while (n--) {
+ lword = *--lside + BIAS;
+ rword = *--rside + carry;
+ hgh = (lword & MASK) + (rword & MASK);
+ low = (lword & ~MASK) + (rword & ~MASK);
+ while (icarry = (hgh & ~MASK) + (low & MASK)) {
+ hgh &= MASK;
+ low &= ~MASK;
+ carry |= icarry;
+ icarry = 0x16 * (icarry >> 4);
+ hgh += icarry & MASK;
+ low += icarry & ~MASK;
+ }
+ carry = ((lword >> CSHIFT) + (rword >> CSHIFT) + (carry >> CSHIFT)) >> 4;
+ *lside = hgh + low + ((6 * carry) << CSHIFT) - BIAS;
+ }
+}
diff --git a/ipl/cfuncs/mkfunc.sh b/ipl/cfuncs/mkfunc.sh
new file mode 100755
index 0000000..a38ead0
--- /dev/null
+++ b/ipl/cfuncs/mkfunc.sh
@@ -0,0 +1,73 @@
+#!/bin/sh
+#
+# mkfunc libname file.o ...
+#
+# looks at the corresponding C files and generates an Icon procedure
+# corresponding to each C function header that matches the pattern below.
+#
+# If a function name begins with "icon_", those characters are removed
+# to form the procedure name. Otherwise, the name is copied verbatim.
+
+LIB=${1?"usage: $0 libname obj..."}
+shift
+
+cat <<ENDHDR
+############################################################################
+#
+# File: cfunc.icn
+#
+# Subject: Procedures implemented in C
+#
+# Author: Gregg M. Townsend
+#
+# Date: June 8, 2001
+#
+############################################################################
+#
+# These Icon procedures transparently load and execute functions
+# implemented in C. Each procedure is a simple stub. The first call
+# to a stub causes it to replace itself with the corresponding
+# dynamically loaded C function, after which the C function processes
+# the arguments and returns a result (or fails). Subsequent calls
+# go straight to the C function without involving the Icon stub.
+#
+# C functions are loaded from a file "$LIB" that is found by
+# searching \$FPATH. The default \$FPATH is set by iconx to include
+# this library.
+#
+############################################################################
+#
+# Requires: Dynamic loading
+#
+############################################################################
+
+# DO NOT EDIT THIS FILE DIRECTLY.
+# It was created mechanically by the shell file "$0".
+# Edit that instead.
+
+link io
+
+\$define LIB "$LIB"
+ENDHDR
+
+LC_ALL=POSIX
+export LC_ALL
+
+for i
+do
+ FNAME=`basename $i .o`
+ echo ""
+ echo "# $FNAME.c:"
+ sed '
+s/ / /g
+s/^int *//
+/^[a-z][a-z0-9_]* *(.*argc.*argv.*).*\/\*:.*\*\//!d
+s/\([a-z0-9_]*\).*)\(.*\)$/\1(a[])\2@ return(\1:=pathload(LIB,"\1"))!a;end/
+s/^[a-z]/procedure &/
+s/\([^"]\)icon_/\1/g
+s/)[ ]*\/\*\(.*\)\*\/.*@/) #\1@/
+ ' $FNAME.c | tr '@' '\012'
+done
+
+echo ""
+echo "#---"
diff --git a/ipl/cfuncs/mklib.sh b/ipl/cfuncs/mklib.sh
new file mode 100755
index 0000000..533af0b
--- /dev/null
+++ b/ipl/cfuncs/mklib.sh
@@ -0,0 +1,32 @@
+#!/bin/sh
+#
+# mklib libname.so obj.o ...
+
+CC=${CC-cc}
+
+LIBNAME=${1?"usage: $0 libname obj..."}
+shift
+
+SYS=`uname -s`
+set -x
+case "$SYS" in
+ Linux*|*BSD*|GNU*)
+ gcc -shared -o $LIBNAME -fPIC "$@";;
+ Darwin*)
+ cc -bundle -undefined suppress -flat_namespace -o $LIBNAME "$@";;
+ SunOS*)
+ $CC $CFLAGS -G -o $LIBNAME "$@" -lc -lsocket;;
+ HP-UX*)
+ ld -b -o $LIBNAME "$@";;
+ IRIX*)
+ ld -shared -o $LIBNAME "$@";;
+ OSF*)
+ ld -shared -expect_unresolved '*' -o $LIBNAME "$@" -lc;;
+ AIX*)
+ # this may not be quite right; it doesn't seem to work yet...
+ ld -bM:SRE -berok -bexpall -bnoentry -bnox -bnogc -brtl -o $LIBNAME "$@";;
+ *)
+ set -
+ echo 1>&2 "don't know how to make libraries under $SYS"
+ exit 1;;
+esac
diff --git a/ipl/cfuncs/osf.c b/ipl/cfuncs/osf.c
new file mode 100644
index 0000000..ce2b4b5
--- /dev/null
+++ b/ipl/cfuncs/osf.c
@@ -0,0 +1,80 @@
+/*
+############################################################################
+#
+# File: osf.c
+#
+# Subject: Function to return OSF system table value
+#
+# Author: Gregg M. Townsend
+#
+# Date: November 17, 1997
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# osftable(id, index, len) returns one element from an OSF table() call.
+# This function is for the OSF operating system, and fails on other systems.
+#
+# See "man table" for a detailed description of the "table" system call
+# and the formats of the structures returned; see /usr/include/table.h
+# for a list of allowed ID values.
+#
+# Defaults: index 0
+# len 100
+#
+############################################################################
+#
+# Requires: OSF or Digital UNIX, dynamic loading
+#
+############################################################################
+*/
+
+#include "icall.h"
+#include <stdlib.h>
+
+#define DEFLENGTH 100
+
+#ifndef __osf__
+int osftable (int argc, descriptor argv[]) { Fail; }
+#else
+
+int osftable (int argc, descriptor argv[]) /*: query OSF system table */
+ {
+ int id, index, len;
+ static void *buf;
+ static int bufsize;
+
+ if (argc == 0)
+ Error(101);
+ ArgInteger(1);
+ id = IntegerVal(argv[1]);
+
+ if (argc > 1) {
+ ArgInteger(2);
+ index = IntegerVal(argv[2]);
+ }
+ else
+ index = 0;
+
+ if (argc > 2) {
+ ArgInteger(3);
+ len = IntegerVal(argv[3]);
+ }
+ else
+ len = DEFLENGTH;
+
+ if (len > bufsize) {
+ buf = realloc(buf, bufsize = len);
+ if (len > 0 && !buf)
+ Error(305);
+ }
+
+ if ((id = table(id, index, buf, 1, len)) != 1)
+ Fail;
+ RetStringN(buf, len);
+ }
+
+#endif
diff --git a/ipl/cfuncs/pack.c b/ipl/cfuncs/pack.c
new file mode 100644
index 0000000..60160cc
--- /dev/null
+++ b/ipl/cfuncs/pack.c
@@ -0,0 +1,261 @@
+/*
+############################################################################
+#
+# File: pack.c
+#
+# Subject: Functions to pack and unpack binary data
+#
+# Author: Gregg M. Townsend
+#
+# Date: November 17, 1997
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# s := pack(value, flags, width)
+# x := unpack(string, flags)
+#
+# Flag characters are as follows:
+#
+# l -- little-endian [default]
+# b -- big-endian
+# n -- host platform's native packing order
+#
+# i -- integer [default]
+# u -- unsigned integer
+# r -- real (host platform's native float or double format)
+#
+# The default width is 4.
+#
+# Integer values must fit in a standard Icon integer (not large integer).
+# Consequently, a word-sized value cannot have the high bit set if unsigned.
+# Floating values can only be converted to/from a string width matching
+# sizeof(float) or sizeof(double).
+#
+# Size/type combinations that can't be handled produce errors.
+# Valid combinations produce failure if the value overflows.
+#
+# Some of this code assumes a twos-complement architecture with 8-bit bytes.
+#
+############################################################################
+#
+# Requires: Dynamic loading
+#
+############################################################################
+*/
+
+#include "icall.h"
+#include <string.h>
+
+#define F_LTL 0x100 /* little-endian */
+#define F_BIG 0x200 /* big-endian */
+#define F_REV 0x400 /* internal flag: reversal needed */
+
+#define F_INT 1 /* integer */
+#define F_UNS 2 /* unsigned integer */
+#define F_REAL 4 /* real */
+
+#define DEF_WIDTH 4 /* default width */
+#define MAX_WIDTH 256 /* maximum width */
+
+static unsigned long testval = 1;
+#define LNATIVE (*(char*)&testval) /* true if machine is little-endian */
+
+static int flags(char *s, int n);
+static void *memrev(void *s1, void *s2, size_t n);
+
+/*
+ * pack(value, flags, width)
+ */
+int pack(int argc, descriptor argv[]) /*: pack integer into bytes */
+ {
+ int f, i, n, x;
+ long v;
+ unsigned char *s, obuf[MAX_WIDTH];
+ union { float f; double d; unsigned char buf[MAX_WIDTH]; } u;
+
+ /*
+ * check arguments
+ */
+ if (argc == 0)
+ Error(102); /* no value given */
+
+ if (argc > 1) {
+ ArgString(2);
+ if ((f = flags(StringAddr(argv[2]), StringLen(argv[2]))) == 0)
+ ArgError(2, 205); /* illegal flag string */
+ }
+ else
+ f = flags("", 0);
+
+ if (argc > 2) {
+ ArgInteger(3);
+ n = IntegerVal(argv[3]);
+ if (n < 0 || n > MAX_WIDTH)
+ ArgError(3, 205); /* too long to handle */
+ }
+ else
+ n = DEF_WIDTH;
+
+ if (f & F_REAL) {
+
+ /*
+ * pack real value
+ */
+ ArgReal(1);
+ if (n == sizeof(double))
+ u.d = RealVal(argv[1]);
+ else if (n == sizeof(float))
+ u.f = RealVal(argv[1]);
+ else
+ ArgError(3, 205); /* illegal length for real value */
+
+ if (f & F_REV)
+ RetStringN(memrev(obuf, u.buf, n), n);
+ else
+ RetStringN((char *)u.buf, n);
+ }
+
+ /*
+ * pack integer value
+ */
+ ArgInteger(1);
+ v = IntegerVal(argv[1]); /* value */
+
+ if (v >= 0)
+ x = 0; /* sign extension byte */
+ else if (f & F_UNS)
+ Fail; /* invalid unsigned value */
+ else
+ x = (unsigned char) -1;
+
+ for (s = obuf, i = 0; i < sizeof(long); i++) {
+ *s++ = v & 0xFF; /* save in little-endian fashion */
+ v = ((unsigned long)v) >> 8;
+ }
+ while (i++ < n)
+ *s++ = x; /* extend if > sizeof(long) */
+
+ for (i = n; i < sizeof(long); i++) /* check that all bits did fit */
+ if (obuf[i] != x)
+ Fail; /* overflow */
+
+ if (f & F_BIG)
+ RetStringN(memrev(u.buf, obuf, n), n);
+ else
+ RetStringN((char *)obuf, n);
+ }
+
+/*
+ * unpack(string, flags)
+ */
+int unpack(int argc, descriptor argv[]) /*: unpack integer from bytes */
+ {
+ int f, i, n, x;
+ long v;
+ unsigned char *s;
+ union { float f; double d; unsigned char buf[MAX_WIDTH]; } u;
+
+ /*
+ * check arguments
+ */
+ ArgString(1);
+ s = (unsigned char *)StringAddr(argv[1]);
+ n = StringLen(argv[1]);
+ if (n > MAX_WIDTH)
+ ArgError(1, 205); /* too long to handle */
+
+ if (argc > 1) {
+ ArgString(2);
+ if ((f = flags(StringAddr(argv[2]), StringLen(argv[2]))) == 0)
+ ArgError(2, 205); /* illegal flag string */
+ }
+ else
+ f = flags("", 0);
+
+ if (f & F_REAL) {
+ /*
+ * unpack real value
+ */
+ if (f & F_REV)
+ memrev(u.buf, s, n);
+ else
+ memcpy(u.buf, s, n);
+
+ if (n == sizeof(double))
+ RetReal(u.d);
+ else if (n == sizeof(float))
+ RetReal(u.f);
+ else
+ ArgError(1, 205); /* illegal length for real value */
+ }
+
+ /*
+ * unpack integer value
+ */
+ if (f & F_BIG)
+ s = memrev(u.buf, s, n); /* put in little-endian order */
+ for (v = i = 0; i < n && i < sizeof(long); i++)
+ v |= *s++ << (8 * i); /* pack into a long */
+
+ if (v >= 0)
+ x = 0; /* sign extension byte */
+ else if (f & F_UNS)
+ Fail; /* value overflows as unsigned */
+ else
+ x = (unsigned char) -1;
+
+ for (; i < n; i++) /* check bytes beyond sizeof(long) */
+ if (*s++ != x)
+ Fail; /* value overflows a long */
+
+ RetInteger(v); /* return value */
+ }
+
+
+/*
+ * flags(addr, len) -- interpret flag string, return 0 if error
+ */
+static int flags(char *s, int n)
+ {
+ int f = 0;
+
+ while (n--) switch(*s++) {
+ case 'l': f |= F_LTL; break;
+ case 'b': f |= F_BIG; break;
+ case 'n': f |= (LNATIVE ? F_LTL : F_BIG); break;
+ case 'i': f |= F_INT; break;
+ case 'u': f |= F_UNS + F_INT; break;
+ case 'r': f |= F_REAL; break;
+ default: return 0;
+ }
+
+ if (((f & F_LTL) && (f & F_BIG)) | ((f & F_INT) && (f & F_REAL)))
+ return 0; /* illegal conflict */
+
+ if (!(f & F_BIG))
+ f |= F_LTL; /* default packing is little-endian */
+ if (!(f & F_REAL))
+ f |= F_INT; /* default type is integer */
+
+ if (f & (LNATIVE ? F_BIG : F_LTL))
+ f |= F_REV; /* set flag if non-native mode */
+
+ return f;
+ }
+
+
+/*
+ * memrev(s1, s2, n) -- copy reversal of s2 into s1, returning s1
+ */
+static void *memrev(void *s1, void *s2, size_t n)
+ {
+ unsigned char *c1 = s1;
+ unsigned char *c2 = (unsigned char *)s2 + n;
+ while (n-- > 0)
+ *c1++ = *--c2;
+ return s1;
+ }
diff --git a/ipl/cfuncs/ppm.c b/ipl/cfuncs/ppm.c
new file mode 100644
index 0000000..b9652e1
--- /dev/null
+++ b/ipl/cfuncs/ppm.c
@@ -0,0 +1,581 @@
+/*
+############################################################################
+#
+# File: ppm.c
+#
+# Subject: Functions to manipulate PPM files in memory
+#
+# Author: Gregg M. Townsend
+#
+# Date: November 17, 1997
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# These functions manipulate raw (P6) PPM image files in memory.
+# The images must not contain comment strings.
+#
+# ppmwidth(s) -- return width of PPM image.
+# ppmheight(s) -- return height of PPM image.
+# ppmmax(s) -- return maximum value in PPM header.
+# ppmdata(s) -- return data portion of PPM image.
+#
+# ppmimage(s,p,f) -- quantify image s using palette p, with flags f.
+# Returns an Icon image string. Flag "o" selects ordered dithering.
+# Defaults: p="c6", f="o"
+#
+# ppmstretch(s,lo,hi,max) -- apply contrast stretch operation
+# Returns a PPM string image that results from setting all
+# values <= lo to zero, all values >= hi to max, with values
+# between scaling linearly. If hi = lo + 1, this becomes a
+# simple threshold operation. If lo=0 and hi=ppmmax(s), this
+# simply scales an image to a new maximum.
+#
+# Requirements: 0 <= lo < hi <= ppmmax(s), 1 <= max <= 255.
+# Defaults: lo=0, hi=ppmmax(s), max=255.
+#
+# ppm3x3(s,a,b,c,d,e,f,g,h,i) -- apply 3x3 convolution to PPM image.
+# The matrix of real numbers [[a,b,c],[d,e,f],[g,h,i]] is used
+# as a transformation matrix applied independently to the three
+# color components of the image.
+#
+############################################################################
+#
+# Requires: Dynamic loading
+#
+############################################################################
+*/
+
+
+
+#include "icall.h"
+#include <ctype.h>
+#include <string.h>
+#include <stdlib.h>
+
+int palnum(descriptor *d);
+char *rgbkey(int p, double r, double g, double b);
+
+
+
+typedef struct { /* ppminfo: struct describing a ppm image */
+ int w, h; /* width and height */
+ int max; /* maximum value */
+ long npixels; /* total number of pixels */
+ long nbytes; /* total number of pixels */
+ char *data; /* pointer to start of raw data; null indicates error */
+} ppminfo;
+
+static ppminfo ppmcrack(descriptor d);
+static descriptor ppmalc(int w, int h, int max);
+static char *rowextend(char *dst, char *src, int w, int nbr);
+static int ppmrows(ppminfo hdr, int nbr, int (*func) (), long arg);
+static int sharpenrow(char *a[], int w, int i, long max);
+static int convrow(char *a[], int w, int i, long max);
+
+static char *out; /* general purpose global output pointer */
+
+
+
+/* macros */
+
+/* ArgPPM(int n, ppminfo hdr) -- validate arg n, init hdr */
+#define ArgPPM(n,hdr) do {\
+ ArgString(n); \
+ hdr = ppmcrack(argv[n]); \
+ if (!hdr.data) Fail; \
+} while(0)
+
+/* AlcResult(int w, h, max, ppminfo hdr) -- alc result string, init hdr */
+/* WARNING -- can move other strings; refresh addresses from descriptors. */
+#define AlcResult(w, h, max, hdr) do {\
+ descriptor d = ppmalc(w, h, max); \
+ if (d.vword == 0) Error(306); \
+ hdr = ppmcrack(argv[0] = d); \
+} while(0)
+
+
+
+/* ppm info functions */
+
+int ppmwidth(int argc, descriptor *argv) /*: extract width of PPM string */
+ {
+ ppminfo hdr;
+
+ ArgPPM(1, hdr);
+ RetInteger(hdr.w);
+ }
+
+int ppmheight(int argc, descriptor *argv) /*: extract height of PPM string */
+ {
+ ppminfo hdr;
+
+ ArgPPM(1, hdr);
+ RetInteger(hdr.h);
+ }
+
+int ppmmax(int argc, descriptor *argv) /*: extract max of PPM string */
+ {
+ ppminfo hdr;
+
+ ArgPPM(1, hdr);
+ RetInteger(hdr.max);
+ }
+
+int ppmdata(int argc, descriptor *argv) /*: extract data from PPM string */
+ {
+ ppminfo hdr;
+
+ ArgPPM(1, hdr);
+ RetAlcString(hdr.data, hdr.nbytes);
+ }
+
+
+
+/* ppmstretch(s,lo,hi) -- apply contrast stretch operation */
+
+int ppmstretch(int argc, descriptor *argv) /*: stretch contrast of PPM string */
+ {
+ ppminfo src, dst;
+ int lo, hi, max, i, v;
+ float m;
+ char *d, *s;
+
+ ArgPPM(1, src);
+
+ if (argc < 2 || IconType(argv[2]) == 'n')
+ lo = 0;
+ else {
+ ArgInteger(2);
+ lo = IntegerVal(argv[2]);
+ if (lo < 0 || lo >= src.max)
+ ArgError(2, 205);
+ }
+
+ if (argc < 3 || IconType(argv[3]) == 'n')
+ hi = src.max;
+ else {
+ ArgInteger(3);
+ hi = IntegerVal(argv[3]);
+ if (hi <= lo || hi > src.max)
+ ArgError(3, 205);
+ }
+
+ if (argc < 4 || IconType(argv[4]) == 'n')
+ max = 255;
+ else {
+ ArgInteger(4);
+ max = IntegerVal(argv[4]);
+ if (max < 1 || max > 255)
+ ArgError(4, 205);
+ }
+
+ m = (float)(max + 1) / (hi - lo);
+
+ AlcResult(src.w, src.h, max, dst);
+ src = ppmcrack(argv[1]); /* may have moved */
+ d = dst.data;
+ s = src.data;
+ for (i = 0; i < dst.nbytes; i++) {
+ v = m * ((*s++ & 0xFF) - lo);
+ if (v < 0) v = 0;
+ else if (v > dst.max) v = dst.max;
+ *d++ = v;
+ }
+ Return;
+ }
+
+
+
+/* ppmsharpen(s) -- apply fixed sharpening convolution */
+
+int ppmsharpen(int argc, descriptor *argv) /*: sharpen a PPM string */
+ {
+ int rv;
+ ppminfo src, dst;
+
+ ArgPPM(1, src);
+ AlcResult(src.w, src.h, src.max, dst);
+ src = ppmcrack(argv[1]); /* may have moved */
+
+ out = dst.data;
+ rv = ppmrows(src, 1, sharpenrow, src.max);
+ if (rv == 0)
+ Return;
+ argv[0] = nulldesc;
+ return rv;
+ }
+
+static int sharpenrow(char *a[], int w, int i, long max)
+ {
+ unsigned char *prev, *curr, *next;
+ int v;
+
+ prev = (unsigned char *) a[-1];
+ curr = (unsigned char *) a[0];
+ next = (unsigned char *) a[1];
+ w *= 3;
+ while (w--) {
+ v = 2.0 * curr[0]
+ - .10 * (prev[-3] + prev[3] + next[-3] + next[3])
+ - .15 * (prev[0] + curr[-3] + curr[3] + next[0]);
+ if (v < 0)
+ v = 0;
+ else if (v > max)
+ v = max;
+ *out++ = v;
+ prev++;
+ curr++;
+ next++;
+ }
+ return 0;
+ }
+
+
+
+/* ppm3x3(s,a,b,c,d,e,f,g,h,i) -- apply 3x3 convolution matrix */
+
+static float cells[9];
+
+int ppm3x3(int argc, descriptor *argv) /*: convolve PPM with matrix */
+ {
+ int rv, i;
+ ppminfo src, dst;
+
+ ArgPPM(1, src);
+ for (i = 0; i < 9; i++) {
+ ArgReal(i + 2);
+ cells[i] = RealVal(argv[i + 2]);
+ }
+
+ AlcResult(src.w, src.h, src.max, dst);
+ src = ppmcrack(argv[1]); /* may have moved */
+
+ out = dst.data;
+ rv = ppmrows(src, 1, convrow, src.max);
+ if (rv == 0)
+ Return;
+ argv[0] = nulldesc;
+ return rv;
+ }
+
+static int convrow(char *a[], int w, int i, long max)
+ {
+ unsigned char *prev, *curr, *next;
+ int v;
+
+ prev = (unsigned char *) a[-1];
+ curr = (unsigned char *) a[0];
+ next = (unsigned char *) a[1];
+ w *= 3;
+ while (w--) {
+ v = cells[0] * prev[-3] + cells[1] * prev[0] + cells[2] * prev[3]
+ + cells[3] * curr[-3] + cells[4] * curr[0] + cells[5] * curr[3]
+ + cells[6] * next[-3] + cells[7] * next[0] + cells[8] * next[3];
+ if (v < 0)
+ v = 0;
+ else if (v > max)
+ v = max;
+ *out++ = v;
+ prev++;
+ curr++;
+ next++;
+ }
+ return 0;
+ }
+
+
+
+/* ppmimage(s,p,f) -- quantify image s using palette p, returning Icon image. */
+
+#define MDIM 16 /* dither matrix dimension */
+#define MSIZE (MDIM * MDIM) /* total size */
+
+int ppmimage(int argc, descriptor *argv) /*: dither PPM to Icon image */
+ {
+ int i, p, row, col, ir, ig, ib;
+ double m, gd, r, g, b, dither[MSIZE], *dp, d;
+ char *pname, *flags, *s, *t, *rv;
+ ppminfo hdr;
+ static double dmults[7] = {0., 1./3., 1./1., 1./2., 1./3., 1./4., 1./5.};
+ static double gmults[7] = {0., 3./6., 1./2., 1./3., 1./4., 1./5., 1./6.};
+ static unsigned char dfactor[MSIZE] = {
+ 0,128, 32,160, 8,136, 40,168, 2,130, 34,162, 10,138, 42,170,
+ 192, 64,224, 96,200, 72,232,104,194, 66,226, 98,202, 74,234,106,
+ 48,176, 16,144, 56,184, 24,152, 50,178, 18,146, 58,186, 26,154,
+ 240,112,208, 80,248,120,216, 88,242,114,210, 82,250,122,218, 90,
+ 12,140, 44,172, 4,132, 36,164, 14,142, 46,174, 6,134, 38,166,
+ 204, 76,236,108,196, 68,228,100,206, 78,238,110,198, 70,230,102,
+ 60,188, 28,156, 52,180, 20,148, 62,190, 30,158, 54,182, 22,150,
+ 252,124,220, 92,244,116,212, 84,254,126,222, 94,246,118,214, 86,
+ 3,131, 35,163, 11,139, 43,171, 1,129, 33,161, 9,137, 41,169,
+ 195, 67,227, 99,203, 75,235,107,193, 65,225, 97,201, 73,233,105,
+ 51,179, 19,147, 59,187, 27,155, 49,177, 17,145, 57,185, 25,153,
+ 243,115,211, 83,251,123,219, 91,241,113,209, 81,249,121,217, 89,
+ 15,143, 47,175, 7,135, 39,167, 13,141, 45,173, 5,133, 37,165,
+ 207, 79,239,111,199, 71,231,103,205, 77,237,109,197, 69,229,101,
+ 63,191, 31,159, 55,183, 23,151, 61,189, 29,157, 53,181, 21,149,
+ 255,127,223, 95,247,119,215, 87,253,125,221, 93,245,117,213, 85,
+};
+
+ ArgString(1);
+
+ if (argc < 2 || IconType(argv[2]) == 'n') {
+ p = 6;
+ pname = "c6";
+ }
+ else {
+ ArgString(2);
+ p = palnum(&argv[2]);
+ if (p == 0) Fail;
+ if (p == -1) ArgError(1, 103);
+ pname = StringVal(argv[2]);
+ }
+
+ if (argc < 3 || IconType(argv[3]) == 'n')
+ flags = "o";
+ else {
+ ArgString(3);
+ flags = StringVal(argv[3]);
+ }
+
+ hdr = ppmcrack(argv[1]);
+ if (!hdr.data)
+ Fail; /* PPM format error */
+
+ if (!strchr(flags, 'o'))
+ m = gd = 0.0; /* no dithering */
+ else if (p > 0) {
+ m = dmults[p] - .0001; /* color dithering magnitude */
+ gd = gmults[p]; /* correction factor if gray input */
+ }
+ else {
+ m = 1.0 / (-p - .9999); /* grayscale dithering magnitude */
+ gd = 1.0; /* no correction needed */
+ }
+
+ for (i = 0; i < MSIZE; i++) /* build dithering table */
+ dither[i] = m * (dfactor[i] / (double)(MSIZE)- 0.5);
+
+ rv = alcstr(NULL, 10 + hdr.npixels); /* allocate room for output string */
+ if (!rv)
+ Error(306);
+ hdr = ppmcrack(argv[1]); /* get addr again -- may have moved */
+ sprintf(rv, "%d,%s,", hdr.w, pname);
+ t = rv + strlen(rv);
+
+ m = 1.0 / hdr.max;
+ s = hdr.data;
+ for (row = hdr.h; row > 0; row--) {
+ dp = &dither[MDIM * (row & (MDIM - 1))];
+ for (col = hdr.w; col > 0; col--) {
+ d = dp[col & (MDIM - 1)];
+ ir = *s++ & 0xFF;
+ ig = *s++ & 0xFF;
+ ib = *s++ & 0xFF;
+ if (ir == ig && ig == ib) {
+ g = m * ig + gd * d;
+ if (g < 0) g = 0; else if (g > 1) g = 1;
+ r = b = g;
+ }
+ else {
+ r = m * ir + d; if (r < 0) r = 0; else if (r > 1) r = 1;
+ g = m * ig + d; if (g < 0) g = 0; else if (g > 1) g = 1;
+ b = m * ib + d; if (b < 0) b = 0; else if (b > 1) b = 1;
+ }
+ *t++ = *(rgbkey(p, r, g, b));
+ }
+ }
+
+ RetAlcString(rv, t - rv);
+ }
+
+
+
+/************************* internal functions *************************/
+
+
+
+/*
+ * ppmalc(w, h, max) -- allocate new ppm image and initialize header
+ *
+ * If allocation fails, the address in the returned descriptor is NULL.
+ */
+static descriptor ppmalc(int w, int h, int max)
+ {
+ char buf[32];
+ descriptor d;
+
+ sprintf(buf, "P6\n%d %d\n%d\n", w, h, max);
+ d.dword = strlen(buf) + 3 * w * h;
+ d.vword = (word)alcstr(NULL, d.dword);
+ if (d.vword != 0)
+ strcpy((void *)d.vword, buf);
+ return d;
+ }
+
+
+
+/* ppmcrack(d) -- crack PPM header, setting max=0 on error */
+
+static ppminfo ppmcrack(descriptor d)
+ {
+ int n;
+ char *s;
+ ppminfo info;
+ static ppminfo zeroes;
+
+ s = StringAddr(d);
+ if (sscanf(s, "P6 %d %d %n", &info.w, &info.h, &n) < 2)
+ return zeroes; /* not a raw PPM file */
+
+ /* can't scanf for "max" because it consumes too much trailing whitespace */
+ info.max = 0;
+ for (s += n; isspace(*s); s++)
+ ;
+ while (isdigit(*s))
+ info.max = 10 * info.max + *s++ - '0';
+ if (info.max == 0 || info.max > 255)
+ return zeroes; /* illegal max value for raw PPM */
+
+ /* now consume exactly one more whitespace character */
+ if (isspace(*s))
+ s++;
+
+ info.npixels = (long)info.w * (long)info.h;
+ info.nbytes = 3 * info.npixels;
+ if (s + info.nbytes > StringAddr(d) + StringLen(d))
+ return zeroes; /* file was truncated */
+
+ info.data = s;
+ return info;
+ }
+
+
+
+/*
+ * ppmrows(hdr, nbr, func, arg) -- extend rows and call driver function
+ *
+ * Calls func(a, w, i, arg) for each row of the PPM image identified by hdr,
+ * where
+ * a is a pointer to a pointer to the first byte of the row (see below)
+ * w is the width of a row, in pixels
+ * i is the row number
+ * arg is passed along from the call to ppmrows
+ *
+ * When nbr > 0, this indicates that func() needs to read up to nbr pixels
+ * above, below, left, and/or right of each source pixel; ppmrows copies
+ * and extends the rows to make this easy. The argument "a" passed to func
+ * is a pointer to the center of an array of row pointers that extends by
+ * nbr rows in each direction. That is, a[0] points to the current row;
+ * a[-1] points to the previous row, a[1] to the next row, and so on.
+ *
+ * Each row is extended by nbr additional pixels in each direction by the
+ * duplication of the first and last pixels. The pointers in the array "a"
+ * skip past the initial duplicates. Thus a[0][0] is the first byte
+ * (the red byte) of the first pixel, a[0][-3] is its duplicate, and
+ * a[0][3] is the first byte of the second pixel of the row.
+ *
+ * The idea behind all this complication is to make it easy to perform
+ * neighborhood operations. See any caller of ppmrows for an example.
+ *
+ * If ppmrows cannot allocate memory, it returns error code 305.
+ * If func returns nonzero, ppmrows returns that value immediately.
+ * Otherwise, ppmrows returns zero.
+ */
+
+static int ppmrows(ppminfo hdr, int nbr, int (*func) (), long arg)
+ {
+ char **a, *s;
+ void *buf;
+ int i, rv, np, row, rowlen;
+
+ /* process nbr=0 without any copying */
+ if (nbr <= 0) {
+ s = hdr.data;
+ for (row = 0; row < hdr.h; row++) {
+ rv = func(&s, hdr.w, row, arg);
+ if (rv != 0)
+ return rv;
+ s += 3 * hdr.w;
+ }
+ return 0;
+ }
+
+ /* allocate memory for pointers and data */
+ np = 2 * nbr + 1; /* number of pointers */
+ rowlen = 3 * (nbr + hdr.w + nbr); /* length of one extended row */
+ a = buf = malloc(np * sizeof(char *) + np * rowlen);
+ if (buf == NULL)
+ return 305;
+
+ /* set pointers to row buffers */
+ s = (char *)buf + np * sizeof(char *) + 3 * nbr;
+ for (i = 0; i < np; i++) {
+ *a++ = s;
+ s += rowlen;
+ }
+ a -= nbr + 1; /* point to center row */
+
+ /* initialize buffers */
+ for (i = -nbr; i < 0; i++) /* duplicates of first row */
+ rowextend(a[i], hdr.data, hdr.w, nbr);
+ for (i = 0; i <= nbr; i++) /* first nbr+1 rows */
+ rowextend(a[i], hdr.data + 3 * i * hdr.w, hdr.w, nbr);
+
+ /* iterate through rows */
+ for (row = 0; row < hdr.h; row++) {
+
+ /* call function for this row */
+ rv = func(a, hdr.w, row, arg);
+ if (rv != 0) {
+ free(buf);
+ return rv;
+ }
+
+ /* rotate row pointers */
+ s = a[-nbr];
+ for (i = -nbr; i < nbr; i++)
+ a[i] = a[i+1];
+ a[nbr] = s;
+
+ /* replace oldest with new row */
+ if (row + nbr < hdr.h)
+ rowextend(s, hdr.data + 3 * (row + nbr) * hdr.w, hdr.w, nbr);
+ else
+ rowextend(s, hdr.data + 3 * (hdr.h - 1) * hdr.w, hdr.w, nbr);
+
+ }
+
+ free(buf);
+ return 0;
+ }
+
+
+
+/*
+ * rowextend(dst, src, w, nbr) -- extend row on both ends
+ *
+ * Copy w bytes from src to dst, extending both ends by nbr copies of
+ * the first/last 3-byte pixel. w is the row width in pixels.
+ * Returns unextended dst pointer.
+ */
+static char *rowextend(char *dst, char *src, int w, int nbr)
+ {
+ char *s1, *s2, *d1, *d2;
+
+ memcpy(dst, src, 3 * w);
+ d1 = dst;
+ d2 = dst + 3 * w;
+ s1 = d1 + 3;
+ s2 = d2 - 3;
+ nbr *= 3;
+ while (nbr--) {
+ *--d1 = *--s1;
+ *d2++ = *s2++;
+ }
+ return dst;
+ }
diff --git a/ipl/cfuncs/process.c b/ipl/cfuncs/process.c
new file mode 100644
index 0000000..ad241ff
--- /dev/null
+++ b/ipl/cfuncs/process.c
@@ -0,0 +1,73 @@
+/*
+############################################################################
+#
+# File: process.c
+#
+# Subject: Functions to manipulate UNIX processes
+#
+# Author: Gregg M. Townsend
+#
+# Date: November 17, 2004
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# kill(pid, signal) kill process (defaults: pid=0, signal=SIGTERM)
+# getpid() return process ID
+# getuid() return user ID
+# getgid() return group ID
+#
+############################################################################
+#
+# Requires: UNIX, dynamic loading
+#
+############################################################################
+*/
+
+#include <signal.h>
+#include <sys/types.h>
+#include <unistd.h>
+
+#include "icall.h"
+
+int icon_kill (int argc, descriptor argv[]) /*: kill process */
+ {
+ int pid, sig;
+
+ if (argc > 0) {
+ ArgInteger(1);
+ pid = IntegerVal(argv[1]);
+ }
+ else
+ pid = 0;
+
+ if (argc > 1) {
+ ArgInteger(2);
+ sig = IntegerVal(argv[2]);
+ }
+ else
+ sig = SIGTERM;
+
+ if (kill(pid, sig) == 0)
+ RetNull();
+ else
+ Fail;
+ }
+
+int icon_getpid (int argc, descriptor argv[]) /*: query process ID */
+ {
+ RetInteger(getpid());
+ }
+
+int icon_getuid (int argc, descriptor argv[]) /*: query user ID */
+ {
+ RetInteger(getuid());
+ }
+
+int icon_getgid (int argc, descriptor argv[]) /*: query group ID */
+ {
+ RetInteger(getgid());
+ }
diff --git a/ipl/cfuncs/tconnect.c b/ipl/cfuncs/tconnect.c
new file mode 100644
index 0000000..37579bc
--- /dev/null
+++ b/ipl/cfuncs/tconnect.c
@@ -0,0 +1,96 @@
+/*
+############################################################################
+#
+# File: tconnect.c
+#
+# Subject: Function to open TCP connection
+#
+# Author: Gregg M. Townsend
+#
+# Date: October 3, 1995
+#
+############################################################################
+#
+# This file is in the public domain.
+#
+############################################################################
+#
+# tconnect(hostname, portnum) establishes a TCP connection to the given
+# host and port, returning an Icon file f.
+#
+# Note that seek(f) must be called when switching between input and output
+# on this bidirectional file. Additionally, the DEC Alpha requires a call
+# to flush(f), after the seek, when switching from input to output.
+#
+############################################################################
+#
+# See also: fpoll.c
+#
+############################################################################
+#
+# Requires: Unix, dynamic loading
+#
+############################################################################
+*/
+
+#include <string.h>
+#include <stdio.h>
+
+#include <fcntl.h>
+#include <netdb.h>
+#include <sys/types.h>
+#include <sys/socket.h>
+#include <netinet/in.h>
+
+#include "icall.h"
+
+
+int tconnect(int argc, descriptor *argv) /*: connect to TCP socket */
+ {
+ char *hostname, filename[1000];
+ unsigned char *p;
+ int port, fd, i, d[4];
+ FILE *fp;
+ struct hostent *h;
+ struct sockaddr_in sin;
+
+ memset(&sin, 0, sizeof(sin));
+
+ /* check arguments */
+ ArgString(1);
+ hostname = StringVal(argv[1]);
+
+ ArgInteger(2);
+ port = IntegerVal(argv[2]);
+
+ /* get host address */
+ if (sscanf(hostname, "%d.%d.%d.%d", &d[0], &d[1], &d[2], &d[3]) == 4) {
+ p = (unsigned char *) &sin.sin_addr;
+ for (i = 0; i < 4; i++)
+ p[i] = d[i];
+ }
+ else {
+ h = gethostbyname(hostname);
+ if (!h)
+ Fail;
+ memcpy(&sin.sin_addr, h->h_addr, sizeof(struct in_addr));
+ endhostent();
+ }
+
+ /* create socket and connect */
+ sin.sin_family = AF_INET;
+ sin.sin_port = htons(port);
+ if ((fd = socket(AF_INET, SOCK_STREAM, 0)) < 0)
+ Fail;
+ if (connect(fd, (struct sockaddr *) &sin, sizeof(sin)) < 0)
+ Fail;
+
+ /* create stdio file pointer */
+ fp = fdopen(fd, "r+");
+ if (!fp)
+ Fail;
+
+ /* return Icon file */
+ sprintf(filename, "%s:%d", hostname, port);
+ RetFile(fp, Fs_Read | Fs_Write, filename);
+ }
generated by cgit v1.2.3 (git 2.39.1) at 2025-07-20 18:51:19 +0000