/*******************************************************************
Le-Lisp (r) version 15.22
Bibliothe`que d'Exe'cution en C
utilisable sur syste`me d`exploitation "a` la UN*X"
*****************************************************************
(r) Le-Lisp est une marque de'pose'e de l'INRIA
*****************************************************************
Ce fichier est en lecture seule. Il est maintenu par :
ILOG S.A.
2 Avenue Gallie'ni
BP 85
94253 Gentilly Cedex
*****************************************************************
$Header: lelisp.c,v 4.43 89/01/16 19:53:14 kuczynsk Exp $
*******************************************************************/
/* Liste des conditionnelles de compilation C :
============================================
Les types et sous-types de syste`mes UNIX :
S5 : System V
SPS9 : sous-type Ridge SPS9
SPS7 : sous-type SPS7 SMX 5.1
CADMUS : sous-type Cadmus
HP9000 : sous-type HP9000 se'rie 300
LEWS : enleve les ← devant les defextern
UNIGRAPH : enleve les ← devant les defextern
IBMRT :
BSD4x : Syste`me Berkeley
BSD41 : de type 4.1
BSD42 : de type 4.2
SEQUENT : sous-type Sequent DYNIX
Les traits pre'sents :
FOREIGN : les messages sont en Breton!
PAGESIZE: La taille des pages
EXECORE : L'image me'moire est un exe'cutable (a.out)
Les autres options fournies a` la compilation C
NBSYST : nume'ro du syste`me a` cre'er
FILEINI : nom du fichier startup
FILIT : indicateur de fichier initial
LLBAN : indicateur de pre'sence de bannie`re
PAGESIZE : la taille d'une page me'moire
TIMEUNIT : fre'quence de l'horloge.
*/
/* Choix du numero du systeme :
----------------------------
1 = VERSADOS, 2 = VME, 3 = MicroMega, 4 = APOLLO
5 = SM90, 6 = PE32OS, 7 = PE32UNIX, 8 = VAXUNIX
9 = VAXVMS, 10= multics, 11= METHEUS, 12= UNIVERSE68
13= MCPM86, 14= PCDOS, 15= MACII, 16= VAXIS3,
17= MAC, 18= SPS9, 19= BELLMAC, 20= VM370UTS,
21= PCS, 22= SUN, 23= HP9000-300, 24= METAVISEUR,
25= GOULD, 26= IBMRT, 27= PYRAMID, 28= SEQUENT
29= UNIGRAPH, 30= CL1000, 31= CL1020, 32= TEKTRONIX 43xx,
33= C, 34= DPX1000, 35= SUN4 36= ATARI,
37= CONVEX.
*/
#ifndef NBSYST
#define NBSYST 22
#endif NBSYST
/* Les autres parametres dependants du systeme
------------------------------------------- */
#ifndef FILEINI
#define FILEINI "/usr/ilog/lelisp/llib/startup.ll"
#endif FILEINI
#define FILIT 0 /* 0 = fichier initial, 1 = core */
#define LLBAN 0 /* 0 = banniere, 1 = silence */
/* la taille des pages (obtenu par pagesize(1) ou getpagesize(2) ou
par la documentation). Doit etre une puissance de 2 >= BIPTR */
#ifndef PAGESIZE
#define PAGESIZE 1024
#endif PAGESIZE
#define align(x) (x = ((x+PAGESIZE-1)&~(PAGESIZE-1)))
/* Les tailles des zones (attention aux Unite's!)
--------------------------------------------- */
/* Les Unites avec lesquelles sont definies les zones */
#define PTR (sizeof (char *))
#define BIPTR (PTR*2)
#define KPTR (PTR*1024)
int SSTACK = 6; /* en K objets de type pointeurs */
int SCODE = 128; /* en K octets */
int SHEAP = 70; /* en K octets */
int SNUMB = 0; /* en K objets de type entiers */
int SFLOAT = 1; /* en K objets de type flottant */
int SVECT = 1; /* en K objets de type vecteur */
int SSTRG = 3; /* en K objets de type chaine */
int SSYMB = 2; /* en K objets de type symboles */
int SCONS = 3; /* en 8 K CONS */
int UCONS = 0; /* en 32 CONS */
/* Si en mode debug, on n'arme pas les interruptions et on ne fait pas
de stty. Principalement pour adb. */
int lldebug=0;
/* les include */
#include <sys/types.h> /* pour tout le monde */
#include <sys/stat.h> /* pour tout le monde */
#include <signal.h> /* pour les signaux */
#include <stdio.h> /* pour les entre'es sorties */
#include <errno.h> /* pour perror(), et le save-core BSD */
#include <a.out.h> /* pour getglobal, et le save-core BSD */
/* V-- cf page 3-218 AIX o/s guide */
#if IBMRT || LEWS || UNIGRAPH
#undef n←name
#endif /* IBMRT LEWS UNIGRAPH */
#ifdef LEWS
/* Les bibliotheques du LEWS exploitent ces traits */
#define u3b 0
#define vax 0
#define u3b5 0
#define sm90 1 /* pour nlist (dans a.out.h) */
#define ridge 0
#endif LEWS
#ifdef BSD42 /* pour runtime */
#include <sys/time.h>
#include <sys/resource.h>
#else BSD42
#include <time.h>
#ifdef Perkin /* le Perkin n'a pas l'include sys/times.h */
struct tms {
long tms←utime;
long proc←system←time;
long child←user←time;
long child←system←time;
};
#else Perkin
#include <sys/times.h> /* pour les autres */
#endif Perkin
#endif BSD42
#ifdef VAXUNIX
#define N←DATADDR(gg) gg.a←text
#endif VAXUNIX
/* les point d'entree de Le-Lisp LLM3 */
extern host←start(), llstdio();
extern float accusingle1;
/*
Les variables globales Le-Lisp.
Elles sont toutes definies dans LLINIT.LLM3
mais doivent etre chargees ici.
*/
/* la pile d'evaluation de Le-Lisp */
extern char *bstack, *estack, *mstack1, *mstack2;
/* les limites des zones des differents types Le-Lisp */
extern char *bcode, *ccode, *ecode,
*bheap, *cheap, *eheap,
*bnumb, *cnumb,
*bfloat, *cfloat,
*bvect, *cvect,
*bstrg, *cstrg,
*bsymb, *csymb,
*bcons, *ccons, *econs;
char *llucode, *lluheap; /* fin des zones code et heap (trous) */
/* le fichier initial et la ligne de commande */
extern int filiz, filit;
extern char *filin;
extern int llban;
/* le numero (type) du systeme Le-Lisp */
extern int nbsyst;
/* Le flag controlant l'impression des erreurs syste`me */
extern int **prtmsgs; /* il est dans le save-core ! */
#define errreturn(M,V) { if(**prtmsgs != 0) perror(M) ; return(V); }
/*
Les variables du lanceur
Elles ne sont pas sauve'es par save-core
*/
/* tailles des zones */
int sstack, scode, sheap, snumb, sfloat, svect, sstrg, ssymb, scons;
/* bits invisibles */
int stbin;
char *btbin;
/* bits du GC */
int stbgc;
char *btbgc;
/* debut et fin de la memoire */
char *bmem;
char *emem;
#ifdef EXECORE
/* Environnement Shell initial (pour le restore-core BSD) */
char **envpini;
#endif EXECORE
/* Path absolu du binaire lelispbin */
char lelispbin[256];
char *getenv();
/* les variables et fonctions du cload */
char *mktemp();
char template[] = "/tmp/lelisp←XXXXXX";
/*
Points d'entree
*/
/* Pour les erreurs */
int out(), oupps();
char *usage();
/*
References externes
*/
/* Allocation de la me'moire */
extern char *brk();
extern char *sbrk();
#define RATE (char *) -1
char *END;
/********************************************************
Gestion du Terminal
********************************************************/
#ifdef S5
#include <fcntl.h>
#include <termio.h>
#endif S5
#ifdef BSD4x
#include <sgtty.h>
#endif BSD4x
#ifdef S5
struct termio tioini, tiolisp; /* les termio initiaux et lisp */
#endif S5
#ifdef BSD4x
struct sgttyb ttyini, ttylisp; /* les stty initiaux et lisp */
#endif BSD4x
int realterminal = 0; /* =0 c'est un vrai terminal */
extern init←stty();
extern lisp←stty();
extern unix←stty();
/* init←stty: intialise les structures stty initiales
-------------------------------------------------- */
init←stty () {
realterminal = isatty(0); /* est-on interactif ? */
if (realterminal != 0) {
#ifdef S5
(void) ioctl(0, TCGETA, &tioini); /* prend le tty initial */
(void) ioctl(0, TCGETA, &tiolisp);
tiolisp.c←cc[VMIN] = 6;
tiolisp.c←cc[VTIME] = 1;
tiolisp.c←iflag &= ~(IGNBRK|INLCR|ICRNL);
tiolisp.c←iflag |= BRKINT;
tiolisp.c←oflag &= ~(OPOST|ONLCR|OCRNL|ONOCR|ONLRET);
tiolisp.c←lflag &= ~(ICANON|ECHO|ECHOE|ECHOK|ECHONL|NOFLSH);
tiolisp.c←lflag |= ISIG;
(void) ioctl(0, TCSETAF, &tiolisp); /* mets le tty lisp */
#endif S5
#ifdef BSD4x
(void) gtty(0, &ttyini); /* prend le tty initial */
(void) gtty(0, &ttylisp); /* recopie' dans le tty lisp */
ttylisp.sg←flags |= CBREAK; /* Lisp est en cbreak -echo -nl */
ttylisp.sg←flags &= ~(ECHO|CRMOD);
#endif BSD4x
}
}
/* lisp←stty: passe le terminal en mode Le-Lisp
-------------------------------------------- */
lisp←stty () {
if (realterminal != 0)
#ifdef S5
(void) ioctl(0, TCSETAF, &tiolisp);
#endif S5
#ifdef BSD4x
(void) stty(0, &ttylisp);
#endif BSD4x
}
/* unix←stty: passe le terminal en mode UN*X
----------------------------------------- */
unix←stty () {
if (realterminal != 0)
#ifdef S5
(void) ioctl(0, TCSETAF, &tioini);
#endif S5
#ifdef BSD4x
(void) stty(0, &ttyini);
#endif BSD4x
}
/********************************************************
Gestion de la Signalerie UN*X
********************************************************/
extern ll←break(); /* dans ../<system>/ll<system>.llm3 */
extern ll←merro();
extern ll←clock();
#ifdef BSD41
onstop41(signo) /* gestion du "stopped job" ↑Z sous BSD 4.1 */
int signo;
{
unix←stty();
sigset(signo, SIG←DFL);
kill(0, signo);
sigset(signo, onstop41);
}
oncont41(signo) /* repasse en Lisp */
int signo;
{
lisp←stty();
}
#endif BSD41
#ifdef BSD42
onstop42(signo) /* gestion du "stopped job" ↑Z sous BSD 4.2 */
int signo;
{
unix←stty();
signal(SIGTSTP, SIG←DFL);
killpg(getpgrp(0), signo);
}
oncont42(signo) /* repasse en mode Lisp */
int signo;
{
lisp←stty();
signal(SIGTSTP, onstop42);
}
shstop42(signo) /* pendant un COMLINE */
int signo;
{
signal(SIGTSTP, SIG←DFL);
killpg(getpgrp(0), signo);
}
shcont42(signo) /* pendant un COMLINE */
int signo;
{
signal(SIGTSTP, shstop42);
}
#endif BSD42
/* init←signal: intialise les signaux UN*X ge're's par Le-Lisp
----------------------------------------------------------- */
init←signal() {
int i;
if ( lldebug == 0 ) {
for(i = 3 ; i <= 12; signal(i++, oupps));
#ifdef BSD41
sigset(SIGTSTP, onstop41);
sigset(SIGCONT, oncont41);
#endif BSD41
#ifdef BSD42
signal(SIGTSTP, onstop42);
signal(SIGCONT, oncont42);
#endif BSD42
}
}
/* pour e'viter un "core-dumped" pour les mauvais signaux */
oupps(n) {
#ifdef FOREIGN
fprintf(stderr, "Le-Lisp : I quit on signal %d\r\n", n);
#else FOREIGN
fprintf(stderr, "signal %d\r\n", n);
fprintf(stderr, "OUPPS! J'ai failli faire un core\r\n");
#endif FOREIGN
out(-1);
}
int←ign () {
if (realterminal != 0)
signal(SIGINT, SIG←IGN); /* interrupt */
signal(SIGILL, SIG←IGN); /* illegal instruction */
signal(SIGBUS, SIG←IGN); /* bus error */
signal(SIGSEGV, SIG←IGN); /* segmentation violation */
signal(SIGTRAP, SIG←IGN); /* trace trap */
signal(SIGFPE, SIG←IGN); /* floating point exception */
#ifdef BSD42
signal(SIGTSTP, shstop42); /* stop generated from keyboard */
signal(SIGCONT, shcont42); /* continue after stop */
#endif
};
/* int←std: passe en mode signaux standard pour le COMLINE
------------------------------------------------------- */
int←std() {
if (realterminal != 0)
signal(SIGINT, SIG←DFL); /* interrupt */
signal(SIGILL, SIG←DFL); /* illegal instruction */
signal(SIGBUS, SIG←DFL); /* bus error */
signal(SIGSEGV, SIG←DFL); /* segmentation violation */
signal(SIGTRAP, SIG←DFL); /* trace trap */
signal(SIGFPE, SIG←DFL); /* floating point exception */
#ifdef BSD42
signal(SIGTSTP, SIG←DFL); /* stop generated from keyboard */
signal(SIGCONT, SIG←DFL); /* continue after stop */
#endif
};
/* inton: arme les signaux UN*X qui seront ge're's par Le-Lisp
----------------------------------------------------------- */
inton () {
if ( lldebug == 0 ) {
if (realterminal != 0)
signal(SIGINT, ll←break); /* interrupt */
signal(SIGILL, ll←merro); /* illegal instruction */
signal(SIGBUS, ll←merro); /* bus error */
signal(SIGSEGV, ll←merro); /* segmentation violation */
signal(SIGTRAP, ll←merro); /* trace trap */
signal(SIGFPE, ll←merro); /* floating point exception */
signal(SIGALRM, ll←clock); /* alarm clock */
#ifdef BSD42
signal(SIGTSTP, onstop42);
signal(SIGCONT, oncont42);
sigsetmask(0);
#endif BSD42
#ifdef IBMRT
signal(SIGDANGER, ll←merro); /* impending lack of page space */
#endif IBMRT
}
}
/* intoff: de'sarme les signaux UN*X ge're's par Le-Lisp
----------------------------------------------------- */
/* ?!?!?! ou` est le code S5 ?!?!? */
intoff () {
if ( lldebug == 0 ) {
#ifdef BSD42
#define mask(s) (1 << ((s)-1))
return(sigblock (mask (SIGALRM) | mask(SIGINT)));
#else BSD42
if (realterminal != 0)
signal(SIGINT, SIG←IGN);
#endif BSD42
}
}
/*******************************************
INLELISP (pour ne pas dire MAIN !!)
point d'entree de Le-Lisp
*******************************************/
inlelisp(argc, argv, envp)
int argc; char **argv, **envp; {
int n, size;
int verbose=0;
#ifdef EXECORE
int selfcore = 0;
#endif EXECORE
#ifdef EXECORE
envpini = envp; /* sauvegarde de l'environnement Shell */
#endif EXECORE
init←signal(); /* initialisation des signaux */
filin = FILEINI; /* initialisation des valeurs par defaut */
filit = FILIT;
llban = LLBAN;
nbsyst = NBSYST;
/* De'cryptage des arguments
Le premier argument est TOUJOURS le path absolu de lelispbin
L'argument 0 est le path absolu du binaire */
strcpy(lelispbin, argv[0]);
#define suitarg() ((++n >= argc) ? usage() : *(argv+n))
#define checkarg(s) (!strcmp(s,*(argv+n)))
for(n = 1; n < argc; n++){
if((**(argv+n) >= '0') && (**(argv+n) <= '9')) {
SCONS = atoi(*(argv+n)); continue; }
if(**(argv+n) == '-'){
#ifdef EXECORE
if(checkarg("-c")){
selfcore = 1; continue; }
#endif EXECORE
if(checkarg("-s")){
llban = 1; continue; }
if(checkarg("-r")) {
filit = 1; filin = suitarg(); continue; }
if(checkarg("-debug")) {
lldebug = 1; continue; }
if(checkarg("-v")) {
verbose = 1; continue; }
if(checkarg("-stack")) {
SSTACK = atoi(suitarg()); continue; }
if(checkarg("-code")) {
SCODE = atoi(suitarg()); continue; }
if(checkarg("-heap")) {
SHEAP = atoi(suitarg()); continue; }
if(checkarg("-number")) {
SNUMB = atoi(suitarg()); continue; }
if(checkarg("-float")) {
SFLOAT = atoi(suitarg()); continue; }
if(checkarg("-vector")) {
SVECT = atoi(suitarg()); continue; }
if(checkarg("-string")) {
SSTRG = atoi(suitarg()); continue; }
if(checkarg("-symbol")) {
SSYMB = atoi(suitarg()); continue; }
if(checkarg("-cons")) {
SCONS = atoi(suitarg()); continue; }
if(checkarg("-ucons")) {
UCONS = atoi(suitarg()); continue; }
(void) usage();
}
filit = 0; filin = *(argv+n);
}
filiz=strlen(filin);
if( lldebug == 0 )
init←stty(); /* initialisation du terminal */
sstack = SSTACK * KPTR;
scode = SCODE * 1024;
sheap = SHEAP * 1024;
snumb = SNUMB * KPTR;
sfloat = SFLOAT * KPTR * 2;
svect = SVECT * KPTR * 2;
sstrg = SSTRG * KPTR * 2;
ssymb = SSYMB * KPTR * 8; /* symbole = 8 pointeurs */
scons = SCONS * KPTR * 16; /* c'est en 8K CONS */
scons += UCONS * PTR * 64; /* c'est en paquet de 32 CONS*/
/*
Verifications des arguments.
Les zones FLOAT (flottants 31 bits) et NUMB (Toutes machines)
peuvent e↑tre demande'es vides
*/
align(snumb);
align(sfloat);
align(scode);
#define nozero(zone, nom) if(zone == 0) zonevide(nom)
nozero(sstack,"stack"); align(sstack);
nozero(sheap,"heap"); align(sheap);
nozero(svect,"vector"); align(svect);
nozero(sstrg,"string"); align(sstrg);
nozero(ssymb,"symbol"); align(ssymb);
nozero(scons,"cons"); align(scons);
/*
Calcul de la taille de la me'moire
*/
stbin = scons / 64; /* taille de la table des bits invisibles */
align(stbin);
stbgc = (snumb+sfloat+svect+sstrg+ssymb+scons)/64; /* bits GC */
align(stbgc);
/* en 2 coups a cause des limites de certains compilos C */
size = sstack+scode+sheap+svect;
size = size+snumb+sfloat+sstrg+ssymb+scons+stbin+stbgc;
if ( verbose )
{printf("FILIT %3d\r\n", filit);
printf("FILIN %s\r\n", filin);
printf("Tailles des zones me'moires (octets)\r\n");
printf("pile %8d\r\n", sstack);
printf("code %8d\r\n", scode);
printf("tas %8d\r\n", sheap);
printf("nombres %8d\r\n", snumb);
printf("flottants %8d\r\n", sfloat);
printf("vecteurs %8d\r\n", svect);
printf("strings %8d\r\n", sstrg);
printf("symboles %8d\r\n", ssymb);
printf("cons %8d\r\n", scons);
printf("bits invisibles %8d\r\n", stbin);
printf("bits de marquage %8d\r\n", stbgc);
printf(" total %8d\r\n", size);
}
#ifdef EXECORE
if(selfcore == 1){
corinit(); /* restauration turbo */
out(-1); /* au cas ou on rentrerait */
}
#endif EXECORE
if (filiz) {
if (close(open(filin, 0)) != 0){
#ifdef FOREIGN
fprintf(stderr, "Le-Lisp : cannot find file %s\r\n", filin);
#else FOREIGN
fprintf(stderr, "Le-Lisp : je ne trouve pas le fichier %s\r\n",
filin);
#endif FOREIGN
out(-1);
}
#ifdef EXECORE
if (filit == 1) {
int dummy;
int *pdummy;
dummy = 1;
pdummy = &dummy;
prtmsgs = &pdummy; /* **prtmsgs existe */
corest(filin);
out(-1);
}
#endif EXECORE
}
/*
Allocation de la me'moire
*/
/* Pour pre'allouer ce qu'il faut pour un GETGLOBAL et e'viter
que le MALLOC n'aille prendre de la place n'importe ou` */
#ifdef BSD4x
(void) getgloba("start");
#endif BSD4x
bmem = sbrk(0);
bmem = (char *) (((long)bmem+PAGESIZE-1)&~(PAGESIZE-1));
(void) brk(bmem);
bmem = sbrk(size);
if(bmem == RATE){
#ifdef FOREIGN
fprintf(stderr, "Le-Lisp : I can't get required memory space\r\n");
#else FOREIGN
fprintf(stderr,
"Le-Lisp : Impossible d'allouer tant de memoire\r\n");
#endif FOREIGN
out(-1);
}
END = sbrk(0); /* pour voir si malloc prend de la place */
/* chargement des variables pre'de'finies */
estack = bmem + (4 * PTR); /* tole'rance minimale */
mstack2 = estack + (128 * PTR); /* Full Stack non re'cupe'rable */
mstack1 = estack + (1024 * PTR); /* Full Stack re'cupe'rable */
bstack = estack + sstack - PTR;
bcode = bstack + PTR;
ccode = bcode;
ecode = bcode + scode;
bheap = ecode;
cheap = bheap;
eheap = bheap + sheap;
bnumb = eheap;
cnumb = bnumb;
bfloat = bnumb + snumb;
cfloat = bfloat;
bvect = bfloat + sfloat;
cvect = bvect;
bstrg = bvect + svect;
cstrg = bstrg;
bsymb = bstrg + sstrg;
csymb = bsymb;
bcons = bsymb + ssymb;
econs = bcons + scons;
ccons = bcons;
btbin = econs;
btbgc = btbin + stbin;
emem = btbgc;
/* et on y va !!! */
llstdio();
lisp←stty();
host←start();
/* au retour (si l'on rentre) on sort joliement */
out(0);
}
/**********************************************************
L E S I M A G E S M E M O I R E S
**********************************************************/
/* l'instruction LLM3 CORSAV doit positionner les 4 variables:
bllm3, ellm3 limites de la zone impure LLM3
llucode fin de la zone code utilise'e
lluheap fin de la zone heap utilise'e */
char *bllm3, *ellm3;
/* Pour ne faire que des petites entrees/sorties (cf NFS ...) */
#ifndef WRITESIZE
#define WRITESIZE 8192
#endif WRITESIZE
WRITE(fd,where,length)
int fd, length;
char *where;
{
int cc, n;
/* Si on veut une trace e'crite: */
/* printf("WRITE: %d %x %x \r\n", fd, where, length); */
n = length;
while(n >= WRITESIZE) {
if ((cc = write(fd, where, WRITESIZE)) < 0)
return(cc);
where += cc;
n -= cc;
}
while(n > 0) {
if ((cc = write(fd, where, n)) < 0)
return(cc);
where += cc;
n -= cc;
}
return(length);
}
/************************************
Les images me'moires en mode EXECORE
************************************/
#ifdef EXECORE
/* Point de lancement effectif */
extern llcorgo(); /* dans ../<system>/ll<system>.llm3 */
/* Variables positionnees au moment du save-core BSD4x */
int corscons; /* taille des CONS de l'image me'moire */
int corstbin; /* bits invisibles de l'image me'moire */
char *corbtbin;
/***********
Le lancement direct (lelispbin -c) d'une image me'moire
re'alise'e en mode EXECORE.
***********/
extern corinit();
corinit () {
int diffcons;
int diffmem;
int i;
if (scons > corscons) {
if (sbrk(0) != END)
#ifdef FOREIGN
fprintf (stderr,
"Le-Lisp : I can't allocate space without hole\r\n");
#else FOREIGN
fprintf (stderr,
"Le-Lisp : je ne peux pas allouer de la place sans trou\r\n");
#endif FOREIGN
else {
/* l'image memoire est plus petite que lelisp courant */
diffcons = (scons - corscons);
/* bits invisibles */
diffmem = diffcons + (diffcons / 64);
/* bits du GC */
diffmem += diffcons / 64;
align(diffmem);
if (sbrk(diffmem) == RATE) {
#ifdef FOREIGN
fprintf (stderr,
"Le-Lisp : not enough ressources to allocate space\r\n");
#else FOREIGN
fprintf (stderr,
"Le-Lisp : Impossible de vous fournir tant de place\r\n");
#endif FOREIGN
out(-1);
}
econs += diffcons;
btbin = econs;
for (i = corstbin; --i >= 0;)
btbin[i] = corbtbin[i];
btbgc = btbin + stbin;
END = sbrk(0);
}
}
inton();
llcorgo();
}
/**********
Save-core en mode EXECORE
***********/
struct exec entete;
char corbuf[1024];
extern int errno;
int corsav (nom) char *nom; {
int fd, fdbin;
long symbols;
long bout;
int n, wr;
llglobb("","",-1); /* pour tuer un sous-sh */
/* positionne les variables pour le restore-core */
corscons = scons;
corbtbin = btbin;
corstbin = stbin;
if((fdbin = open(lelispbin, 0)) == -1)
errreturn(lelispbin, 1);
read(fdbin, &entete, sizeof (struct exec));
if((fd = creat(nom, 0777)) /* rwxrwxrwx | umask */
== -1){
if(errno != ETXTBSY)
errreturn(nom, 1);
if(unlink(nom) == -1)
errreturn(nom, 1);
if((fd = creat(nom, 0777)) /* rwxrwxrwx | umask */
== -1)
errreturn(nom, 1);
}
bout = (long) sbrk(0);
/* c'est la table des symboles de lelispbin qui nous interesse,
Il faut la calculer avant de changer le champ entete.a←data */
symbols = N←SYMOFF(entete);
entete.a←data = bout - N←DATADDR(entete);
entete.a←bss = 0;
entete.a←magic = ZMAGIC;
/* le header */
write(fd, &entete, sizeof(struct exec));
#ifdef SEQUENT
/* recopie du texte */
n = N←DATAOFF(entete) - sizeof(struct exec);
while (n >= 1024) {
read(fdbin, corbuf, 1024);
WRITE(fd, corbuf, 1024);
n -= 1024;
}
read(fdbin, corbuf, n);
WRITE(fd, corbuf, n);
WRITE(fd, entete.a←text, llucode - entete.a←text); /* le bas de lisp */
#else SEQUENT
#ifdef VAXUNIX
lseek(fd, N←TXTOFF(entete), 0); /* va au debut du texte */
write(fd, 0L, llucode); /* le bas de lisp */
#endif VAXUNIX
#endif SEQUENT
#ifdef VAXUNIX || SEQUENT
lseek(fd, bheap-llucode, 1); /* le trou fin de code */
WRITE(fd, bheap, lluheap-bheap); /* le tas */
lseek(fd, bnumb-lluheap, 1); /* le trou fin de tas */
WRITE(fd, bnumb, econs-bnumb); /* le reste */
WRITE(fd, btbin, stbin); /* les bits invisibles */
lseek(fd, bout-(long)btbin-stbin, 1);
#else VAXUNIX || SEQUENT
/* recopie du texte */
n = entete.a←text - sizeof(struct exec);
while (n >= 1024) {
read(fdbin, corbuf, 1024);
wr=write(fd, corbuf, 1024);
if(wr != 1024) { perror ("save-core1"); exit(1); }
n -= 1024;
}
read(fdbin, corbuf, n);
wr=write(fd, corbuf, n);
if(wr != n) { perror ("save-core1.1"); exit(1); }
/* le data */
wr=write(fd, N←DATADDR(entete), bout - N←DATADDR(entete));
if(wr != (int)bout-N←DATADDR(entete))
{ perror ("save-core2"); exit(1);}
#endif VAXUNIX || SEQUENT
/* le symbol */ /* on ajuste, normalement 0 sauf sur Sequent */
lseek(fdbin, symbols, 0);
while ((n = read(fdbin, corbuf, 1024)) > 0)
WRITE(fd, corbuf, n);
close(fdbin);
close(fd);
/* chmod(nom, 493); -rwxr-xr-x Pour garder le umask du user (creat).*/
return(0);
}
/**********
Restore-core en mode EXECORE
***********/
char *corargv[5] = { "lelispbin", "003", "003", "-c", 0};
int corest (nom) char *nom; {
int fd, i;
corargv[0] = nom; /* convention Unix */
if ((fd = open(nom, 0)) == -1)
errreturn(nom, 1);
close(fd);
sprintf(corargv[2], "%d", scons/(8*8*1024));
execve(nom, corargv, envpini);
errreturn (nom, 1);
}
#else EXECORE
/*************************************
Les images me'moires en mode standard
*************************************
L'ente↑te des fichiers image-me'moire contient :
- 3 mots d'identification (12 caracte`res)
- les tailles des zones de l'image me'moire
corsstack
corscode
corsheap
corsnumb
corsfloat
corsvect
corsstrg
corssymb
corscons
corstbin
- les tailles des bouts me'moires sauve's
sllm3
ucode
uheap
urest
*/
#define ID "lelisp core "
struct ENTETE {
char idlelisp[12];
int corsstack;
int corscode;
int corsheap;
int corsnumb;
int corsfloat;
int corsvect;
int corsstrg;
int corssymb;
int corscons;
int corstbin;
int sllm3;
int ucode;
int uheap;
int urest;
} entete;
/**********
Save-core en mode standard
***********/
int corsav (nom) char *nom; {
int fd;
if((fd = creat(nom, 511)) == -1)
errreturn(nom, 1);
strncpy(entete.idlelisp, ID, 12);
entete.corsstack = sstack;
entete.corscode = scode;
entete.corsheap = sheap;
entete.corsnumb = snumb;
entete.corsfloat = sfloat;
entete.corsvect = svect;
entete.corsstrg = sstrg;
entete.corssymb = ssymb;
entete.corscons = scons;
entete.corstbin = stbin;
entete.sllm3 = ellm3 - bllm3;
entete.ucode = llucode - bmem;
entete.uheap = lluheap - bheap;
entete.urest = econs - bnumb;
if(WRITE(fd, &entete, sizeof(struct ENTETE))
!= sizeof(struct ENTETE)){
/* entete */
close(fd);
errreturn(nom, 1);
}
if((WRITE(fd, bllm3, entete.sllm3)) != entete.sllm3){
/* variables LLM3 */
close(fd);
errreturn(nom, 1);
}
if((WRITE(fd, bmem, entete.ucode)) != entete.ucode){
/* code utilise' */
close(fd);
errreturn(nom, 1);
}
if((WRITE(fd, bheap, entete.uheap)) != entete.uheap){
/* heap utilise' */
close(fd);
errreturn(nom, 1);
}
if((WRITE(fd, bnumb, entete.urest)) != entete.urest){
/* zones lisp */
close(fd);
errreturn(nom, 1);
}
if((WRITE(fd, btbin, entete.corstbin)) != entete.corstbin){
/* bits invisibles */
close(fd);
errreturn(nom, 1);
}
if (close(fd) < 0)
errreturn("Le-Lisp",1);
return(0);
}
/**********
Restore-core en mode standard
***********/
int READ(fd,where,length)
int fd, length;
char *where;
{
int cc, n;
/* Si on veut une trace e'crite: */
/* printf("READ: %d %x %x \r\n", fd, where, length); */
return(read(fd, where, length));
}
int corest (nom) char *nom; {
int fd;
if((fd = open(nom, 0)) == -1)
errreturn(nom, 1);
if(READ(fd, &entete, sizeof(struct ENTETE))
!= sizeof(struct ENTETE)){
/* lit l'entete */
close(fd);
errreturn(nom, 1);
}
if(strncmp(entete.idlelisp, ID, 12)){
/* chai↑ne d'identification */
#ifdef FOREIGN
fprintf(stderr, "Le-Lisp : %s is not a core image\r\n", nom);
#else FOREIGN
fprintf(stderr,
"Le-Lisp : %s n'est pas une image memoire\r\n", nom);
#endif FOREIGN
close(fd);
if ((prtmsgs == 0) || (*prtmsgs == 0)) out (-1);
errreturn(nom, 1);
}
if((entete.corsstack != sstack)
|| (entete.corscode != scode)
|| (entete.corsheap != sheap)
|| (entete.corsnumb != snumb)
|| (entete.corsfloat != sfloat)
|| (entete.corsvect != svect)
|| (entete.corsstrg != sstrg)
|| (entete.corssymb != ssymb)){ /* les tailles fixes */
#ifdef FOREIGN
fprintf(stderr,
"Le-Lisp : non compatible core image : %s\r\n", nom);
#else FOREIGN
fprintf(stderr,
"Le-Lisp : image memoire non compatible : %s\r\n", nom);
#endif FOREIGN
close(fd);
if ((prtmsgs == 0) || (*prtmsgs == 0)) out (-1);
errreturn(nom, 1);}
if(entete.corscons > scons){ /* trop gros ? */
#ifdef FOREIGN
fprintf(stderr, "Le-Lisp : core image too large : %s\r\n", nom);
#else FOREIGN
fprintf(stderr, "Le-Lisp : image memoire trop grosse : %s\r\n",
nom);
#endif FOREIGN
close(fd);
errreturn(nom, 1);
}
if((READ(fd, bllm3, entete.sllm3)) != entete.sllm3){
/* variables LLM3 */
close(fd);
errreturn(nom, 1);
}
if((READ(fd, bmem, entete.ucode)) != entete.ucode){
/* code utilise' */
close(fd);
errreturn(nom, 1);
}
if((READ(fd, bheap, entete.uheap)) != entete.uheap){
/* heap utilise' */
close(fd);
errreturn(nom, 1);
}
if((READ(fd, bnumb, entete.urest)) != entete.urest){
/* zones lisp */
close(fd);
errreturn(nom, 1);
}
if((READ(fd, btbin, entete.corstbin)) != entete.corstbin){
/* bits invisibles */
close(fd);
errreturn(nom, 1);
}
close(fd);
return(0);
}
#endif EXECORE
/**********************************************************
cline: Envoi d'une commande au SHELL
**********************************************************/
cline (buff)
char *buff;
{
char *dir;
if (!strncmp(buff, "cd", 2)) { /* c'est peut-etre un cd */
dir = buff + 1;
while (*++dir == ' ')
/* void */ ;
if (*dir=='\0')
cchdir(getenv("HOME")); /* cd tout court */
else if (dir != buff+2)
if (!cchdir(dir)) /* cd PATH */
return (0);
}
unix←stty();
system(buff);
lisp←stty();
inton();
}
system(s)
char *s;
{
int status, pid, w;
#ifdef BSD4x
pid=vfork(); /* on forke astucieusement */
#endif
#ifdef S5
pid =fork(); /* on ne vforke pas en systeme 5 */
#endif
if (pid == 0) {
{int f;
for(f = 3;f < 10; f++)
(void) close(f); /* parano ! */
}
int←std();
execl("/bin/sh", "sh", "-c", s, 0);
←exit(127);
}
int←ign();
while ((w = wait(&status)) != pid && w != -1)
;
if (w == -1)
status = -1;
return(status);
}
/* runtime
=======
Retourne le temps depuis le debut du job.
Ce temps est en secondes (flottant).
L'unite' de temps de'pend du syste`me
*/
#ifndef TIMEUNIT
#ifdef BSD4x
#define TIMEUNIT 60.
#endif BSD4x
#ifdef S5
#define TIMEUNIT 1000.
#endif S5
#endif TIMEUNIT
#ifdef BSD42
double
runtime()
{
struct rusage urusage;
struct timeval utimeval;
getrusage(0, &urusage);
utimeval = urusage.ru←utime;
return(utimeval.tv←sec+(utimeval.tv←usec/1000000.));
}
#else BSD42
double
runtime()
{
struct tms timebuffer;
times(&timebuffer);
return (timebuffer.tms←utime / TIMEUNIT);
}
#endif BSD42
/* sleep
=======
Dort n secondes. Ce temps est en secondes (flottant).
Helas UN*X ne peut dormir qu'un nb de sec fixes
*/
/* En 31bitfloats: l'argument est dans accusingle1 */
csleep()
{
unsigned seconds;
seconds = accusingle1;
sleep(seconds);
}
/* En 64bitfloats: l'argument est en argument(dans la pile) */
cdleep(f)
double f; {
unsigned seconds;
seconds = f;
sleep(seconds);
}
/* cdate
=====
Donne la date courante
*/
extern struct tm *localtime();
cdate (date←lisp)
int *date←lisp;
{
struct tm decoded;
long clock;
clock = time(0);
decoded = *localtime(&clock);
date←lisp[0] = decoded.tm←year + 1900;
date←lisp[1] = decoded.tm←mon + 1;
date←lisp[2] = decoded.tm←mday;
date←lisp[3] = decoded.tm←hour;
date←lisp[4] = decoded.tm←min;
date←lisp[5] = decoded.tm←sec;
date←lisp[7] = decoded.tm←wday == 0 ? 7 : decoded.tm←wday;
}
/* setalarm
========
De'clenche une alarme apre`s n secondes (flottant).
*/
double setalarm(f)
double f; {
#ifdef BSD42
struct itimerval nit,oit;
register int secs;
secs = (long) (f * 1e+6); /* marche si f < 1000000 s ! */
timerclear(&nit.it←interval);
nit.it←value.tv←sec = secs / 1000000;
nit.it←value.tv←usec = secs % 1000000;
if (setitimer(ITIMER←REAL, &nit, &oit) < 0)
return(0);
return(oit.it←value.tv←sec + oit.it←value.tv←usec * 1e-6);
#else BSD42
#ifdef SPS7
/* sur SMX 5.1 il y a un hack pour avoir une horloge au 1/1000ieme */
register int secs;
extern int alarm←on;
secs = (long) (f * -1000.);
if ((secs == 0) && (f != 0.))
secs = -1; /* pour l'arrondi */
return((double) alarm(secs));
#else SPS7
register int secs;
extern int alarm←on;
secs = (long) f;
alarm←on = f == 0. ? 0 : 1;
if ((secs == 0) && (f != 0.))
secs = 1; /* pour l'arrondi */
return((double) alarm(secs));
#endif SPS7
#endif BSD42
}
/* getenvrn
========
Recherche d'une variable de l'environnement.
Rempli le buffer donne argument avec la chaine resultat.
Retourne la taille de la chaine.
*/
extern char *getenv();
int getenvrn (nom, buff)
char *nom, *buff;{
char *u;
if(nom = (u = getenv(nom))){
while(*buff++ = *u++);
return (u-nom-1);
}
return (0);
}
/* getgloba
=========
retourne la valeur associee a un symbole
dans la table des symboles de l'image Le-Lisp.
*/
/* la macro NLISTNAME permet de positionner le champ n←name d'un
e'le'ment de table des symboles.
Ca depend beaucoup des systemes... */
#ifdef BSD4x
#define NLISTNAME(e,i,s) e[i].n←un.n←name = s
#endif BSD4x
#ifdef Perkin
#define NLISTNAME(e,i,s) strncpy(e[i].n←name,s,8)
#endif Perkin
#ifdef CADMUS
#define NLISTNAME(e,i,s) strcpy(e[i].n←name, s)
#endif CADMUS
#ifdef HP9000
#define NLISTNAME(e,i,s) e[i].n←name = (*s == 0) ? NULL : s
#endif HP9000
#ifdef UNIGRAPH | LEWS
#define NLISTNAME(e,i,s) e[i].n←name = (*s == 0) ? s : s+1
#endif UNIGRAPH
/* le defaut */
#ifndef NLISTNAME
#define NLISTNAME(e,i,s) e[i].n←name = s
#endif NLISTNAME
struct nlist elem[2];
int getgloba (strg) char *strg; {
NLISTNAME(elem, 0, strg);
NLISTNAME(elem, 1, "");
nlist(lelispbin, elem);
return(elem[0].n←value);
}
/* le getglobal multiple */
struct lisp←string {
char *pad1;
char *pad2;
char chars;
};
struct lisp←cons {
struct lisp←string **car;
struct lisp←cons *cdr;
};
void mgetglo (list, nil)
struct lisp←cons *list, *nil; {
int length, i;
struct lisp←cons *courant;
struct nlist *elems;
char *name;
length = 0;
for (courant = list; courant != nil;
courant = (struct lisp←cons *)courant->cdr)
length++;
elems = (struct nlist *) malloc ((length+1) * sizeof(struct nlist));
i = 0;
for (courant = list; courant != nil;
courant = (struct lisp←cons *) courant->cdr) {
name = &((*(courant->car))->chars);
NLISTNAME(elems, i, name);
i++;
}
NLISTNAME(elems, i, "");
nlist (lelispbin, elems);
i = 0;
for (courant = list; courant != nil;
courant = (struct lisp←cons *) courant->cdr) {
courant->car = (struct lisp←string **) elems[i].n←value;
i++;
}
free(elems);
}
/* la routine de sortie */
out(code)
int code; {
if(!strncmp(lelispbin, template, 12))
unlink(lelispbin);
unix←stty();
exit(code); /* puis sort avec code de retour */
}
outner () { /* sortie normale depuis lisp */
out(0);
}
outwer () { /* sortie anormale depuis lisp */
out(-1); /* suivant la convention UNIX */
}
outcore() {
perror("Le-Lisp : restore-core : ");
out(-1);
}
/* la syntaxe d'appel de Le-Lisp sous UN*X */
char *usage() {
fprintf(stderr, "Usage : lelisp [-s] [file] [-r file] [number] \
[-stack number] [-code number] [-heap number] [-float number] \
[-vector number] [-string number] [-symbol number] [-cons number]\r\n");
out(-1);
return((char *)-1);
}
zonevide(s){
#ifdef FOREIGN
fprintf(stderr, "Empty %s zone\r\n", s);
#else FOREIGN
fprintf(stderr, "Zone %s vide\r\n", s);
#endif FOREIGN
out(-1);
}
/*
Le chargement dynamique de modules C
Courtesy of L. Fallot
Revu par M. Devin
*/
#define wwe(s) write(2,s,strlen(s))
#define round(x,s) ((((x)-1) & ~((s)-1)) +(s))
#ifndef S5
char *
cload(file, ccode, ecode)
char *file, *ccode, *ecode;{
char *ccoderound;
int taille;
int totale;
char cbuf[512];
int fd;
struct exec header;
int i;
/* remettre 6 X au bout du template
et ge'ne'rer un nom unique */
for(i = strlen(template)-6; i < strlen(template); i++)
template[i] = 'X';
mktemp(template);
/* arrondir ccode a` la taille de la page */
#ifdef SPS9
ccoderound = (char *)round((int)ccode, 4096);
#else SPS9
#ifdef SEQUENT
ccoderound = (char *)round((int)ccode, 2048);
#else SEQUENT
ccoderound = (char *)round((int)ccode, 512);
#endif SEQUENT
#endif SPS9
/* appeler le linker */
sprintf(cbuf,
#ifdef SPS9
"/bin/ld -C -A %s -N -x -T %x -o %s %s -lc",
#else SPS9
#ifdef SUNOS40
"/bin/ld -A %s -Bstatic -N -x -T %x -o %s %s -lc",
#else SUNOS40
"/bin/ld -A %s -N -x -T %x -o %s %s -lc",
#endif SUNOS40
#endif SPS9
lelispbin,
ccoderound,
template,
file);
cline(cbuf);
/* Le link est-il bien fini ? */
fd = open(template, 0);
if (fd < 0) {
perror(template);
unlink(template);
return(ccode);
}
if(read(fd,&header,sizeof(header)) != sizeof(header)) {
perror(template);
close(fd);
unlink(template);
return(ccode);
}
/* le programme ge'ne're' tient-il dans la zone code ? */
taille = round(header.a←text, 4) + round(header.a←data, 4);
totale = taille + header.a←bss;
#ifdef SPS9
totale = round(totale, 4096);
#else SPS9
#ifdef SEQUENT
totale = round(totale, 2048);
#else SEQUENT
totale = round(totale, 512);
#endif SEQUENT
#endif SPS9
if((ccoderound+totale) >= ecode){
fprintf(stderr,
#ifdef FOREIGN
"cload: fatal error full code zone: missing %d Kbytes\r\n",
#else FOREIGN
"cload: erreur fatale zone code pleine: il manque %d Koctets\r\n",
#endif FOREIGN
((ccoderound+totale-ecode))/1024+1);
return(ccode);
}
if (taille != read(fd,ccoderound,taille)) {
perror(template);
close(fd);
unlink(template);
return(ccode);
}
close(fd);
if(!strncmp(lelispbin, template, 12))
unlink(lelispbin);
strcpy(lelispbin, template);
return(ccoderound+totale);
}
#endif S5
/* le repertoire courant */
int
llgetwd (s, l) char *s; int l; {
int code;
#ifdef VAXUNIX
code = getwd(s); /* maxpathlen is the max */
#else VAXUNIX
code = getcwd(s, l);
#endif VAXUNIX
return(code ? strlen(s) : 0);
}
/*
Les tests pour callextern
*/
int cchdir (strg) char *strg; {
return(llglobb(strg,"",0));
}
char *chome () {
return(getenv("HOME"));
}
#ifdef BSD42
char *date () {
char *s;
long temps;
temps = time(0);
s = ctime(&temps);
*(s+24) = '\0';
return(s);
}
#endif BSD42
#ifdef SPS9
#include "lelisp.h"
struct LL←SYMBOL *ll←concat;
struct LL←SYMBOL *
getsym (s) char *s; {
pusharg(LLT←STRING, s);
return (struct LL←SYMBOL *) lispcall (LLT←T, 1, ll←concat);
}
#endif SPS9
int cmoinsun () {
return(-1);
}
double ctest (strg,nf,ni,vect) char *strg; double nf; int ni; int *vect;{
int i;
printf("la chaine est %s\r\n", strg);
printf("le flottant est %e\r\n", nf);
printf("l'entier est %d\r\n", ni);
printf("le vecteur contient vect[0]=%8x,vect[1]=%8x\r\n",
vect[0], vect[1]);
i = vect[0]; vect[0] = vect[1]; vect[1] = i;
return(nf*ni);
}
cboucle () {
while (1) sin(3.14);
}
/*
* newer
* =====
* Lists both of its arguments newer first.
* For CAML module system.
*/
static time←t fdate(name)
char *name;
{
struct stat stbuf;
if (stat(name, &stbuf) == -1) {
return(-1);
}
return(stbuf.st←mtime);
}
newer(name1,name2)
char *name1;
char *name2;
{
time←t date1;
time←t date2;
date1 = fdate (name1);
date2 = fdate (name2);
if (date1 == -1)
if (date2 == -1)
return(-3);
else
return(-1);
if (date2 == -1)
return(-2);
return(date1 > date2);
}
/* Ce paragraphe contient le mecanisme de wildcarding implemente sur
BSD4.2 (SUN) . Il essaie d'etre relativement efficace. la premiere
invocation cree un sous process cshell par vfork les fois suivantes ,
on se contente de piper les noms a expanser et a recuperer les chaines
expansees, apres quoi, lisp en fait ce qu'il veut....
Auteur : Michel DANA
Date : 26 Aout 1988
Modif : 31 Aout 1988 pour adaptation SYSTEM 5
*/
#define MAXLINE 1024
int llglobb (ll←in←string,ll←out←string,maxline)
char *ll←in←string, *ll←out←string ; {
static int pipe←in[2],pipe←out[2],first←time=0,pid=0;
static int incopy, outcopy;
static char *s;
static FILE *stream←in, *stream←out;
static char buff[MAXLINE];
int i;
/* EN */
if (maxline==0) /* chdir */
{if (chdir(ll←in←string)) return(-1); /* chdir pour le process-meme */
if (first←time==0) return(0); /* pas de sous-shell */
}; /* on en reste la */
if (maxline==-1) /* destruction du sous-shell */
{if (first←time==0) /* meme pas cree encore */
return(0); /* on en reste la */
fclose(stream←out); /* on ferme fd vers le sh */
i=wait(0); /* le sous-sh est mort */
fclose(stream←in); /* on ferme le fd venant du sh */
first←time=0; /* on revient a l'etat */
return(i);}; /* on en reste la */
if (first←time==0){
/* c'est la premiere fois, il y a des choses a initialiser */
if (maxline==0) /* chdir? */
return(chdir(ll←in←string)); /* nouvelle directory */
if (pipe(pipe←in) || pipe(pipe←out)) /* erreur? */
return(-7); /* retour lelisp */
incopy=dup(0); /* copie pour cline .... */
outcopy=dup(1); /* ... redirige par <> dans sh */
first←time=1;
#ifdef BSD4x
pid=vfork(); /* on forke astucieusement */
#endif
#ifdef S5
pid =fork(); /* on ne vforke pas en systeme 5 */
#endif
if (pid<0) return(-8); /* erreur? retour lelisp */
if (pid==0) { /* je suis le fils */
close(pipe←in[1]); /* faut pas oublier */
close(pipe←out[0]); /* ces deux inutiles-la */
#ifdef BSD4x
dup2(pipe←in[0],0); /* je reassigne stdin */
dup2(pipe←out[1],1); /* la meme chose sur stdout */
#endif
#ifdef S5
fclose(stdin);
fclose(stdout);
dup(pipe←in[0]);
dup(pipe←out[1]);
#endif
/* freopen("/dev/null","w",stderr); pour ne pas avoir de messages */
/* bizarres en cas d'echec */
execl ("/bin/sh","sh",0); /* sh existe partout */
}
/* le pere maintenant */
close(pipe←in[0]);
close(pipe←out[1]); /* inutile de conserver des descripteurs */
/* inutiles */
stream←in=fdopen(pipe←out[0],"r");
stream←out=fdopen(pipe←in[1],"w");
#ifdef BSD4x
setlinebuf(stream←out); /* fin des initialisations */
#endif
#ifdef S5
setbuf(stream←out,NULL); /*pas de bufferisation....*/
#endif
fputs("trap '' 2\n", stream←out); /* contre les ↑C de Lelisp */
close(incopy); /* seul utilise par le fils */
close(outcopy);
}
if (kill(pid,0)<0) /* le pid, est-il la? */
{fclose(stream←out); /* non, on ferme */
fclose(stream←in); /* les filedesc */
first←time=0; /* pret a recommencer */
if (maxline == 0) return(0); /* chdir?, pas d'erreur */
return(-9);}; /* retour Lelisp */
if (maxline == 0) /* chdir, suite */
{fprintf( /* on compose une commande cd */
stream←out, /* vers le sous-sh */
"cd %s\n", /* le template */
ll←in←string); /* la directory */
return(0);}; /* on en reste la */
if (maxline==-2) /* on simule cline */
{int←ign(); /* prolog de ... */
unix←stty(); /* .. cline */
fprintf /* on construit la commande */
(stream←out, /* vers le sous-sh */
"sh -c 'exec <&%d >&%d; %s'\n", /* recuperation de ... */
incopy, /* ... stdin ...*/
outcopy, /* ... stdout */
ll←in←string); /* la commande-cline */
fprintf(stream←out,"echo $?\n"); /* imprime exit-status */
fscanf(stream←in,"%d",&i); /* recupere exit-status */
lisp←stty(); /* epilog de ... */
inton(); /* ... cline */
return(i);}; /* synchronise' */
s= & buff[0];
buff[0]='\0';
strcat(&buff[0],"echo ll: ");
strcat(&buff[0],ll←in←string);
strcat(&buff[0],"\n");
/* printf("on passe %s \n",&buff[0]); */
fputs(s ,stream←out);
while (strncmp(s=fgets(buff,maxline,stream←in),"ll: ",4)); /* on */
/* tout */
/* garbage */
s=s+4;
strcpy(ll←out←string,s);
return(strlen(ll←out←string));
}