/******************************************************************* 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 HP9300 : 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. LELISPDIR : repertoire du systeme lelisp */ /* 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 /* pour tout le monde */ #include /* pour tout le monde */ #include /* pour les signaux */ #include /* pour les entre'es sorties */ #include /* pour perror(), et le save-core BSD */ #include /* 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 #include #else BSD42 #include #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 /* 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 repertoire lelisp */ char *lelisp_racine; /* 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 #include #endif S5 #ifdef BSD4x #include #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 ..//ll.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; #ifdef HP9300 lelisp_racine = LELISPDIR; #endif HP9300 /* 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 ..//ll.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 HP9300 #define NLISTNAME(e,i,s) e[i].n_name = (*s == 0) ? NULL : s #endif HP9300 #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)); }