| blob | 20046bd3d46a503e955ac1c8ac41c8c1b73dcd99 |
1 #!/bin/sh
2 # This is a shell archive (produced by GNU sharutils 4.6.3).
3 # To extract the files from this archive, save it to some FILE, remove
4 # everything before the `#!/bin/sh' line above, then type `sh FILE'.
5 #
6 lock_dir=_sh04157
7 # Made on 2010-12-08 20:21 UTC by <ying@althonx4>.
8 # Source directory was `/mnt/rd1/apli'.
9 #
10 # Existing files will *not* be overwritten, unless `-c' is specified.
11 #
12 # This shar contains:
13 # length mode name
14 # ------ ---------- ------------------------------------------
15 # 6656 -rw-r--r-- apli/arith.c
16 # 6494 -rw-r--r-- apli/cellt.c
17 # 9497 -rw-r--r-- apli/eval.c
18 # 7383 -rw-r--r-- apli/flow.c
19 # 3790 -rw-r--r-- apli/globals.c
20 # 8984 -rw-r--r-- apli/init.c
21 # 21896 -rw-r--r-- apli/io.c
22 # 2972 -rw-r--r-- apli/iter.c
23 # 8205 -rw-r--r-- apli/kcomp.c
24 # 91 -rw-r--r-- apli/kern.c
25 # 11787 -rw-r--r-- apli/list.c
26 # 4836 -rw-r--r-- apli/logic.c
27 # 3088 -rw-r--r-- apli/map.c
28 # 6887 -rw-r--r-- apli/misc.c
29 # 3014 -rw-r--r-- apli/prop.c
30 # 5265 -rw-r--r-- apli/set.c
31 # 2993 -rw-r--r-- apli/str.c
32 # 2489 -rw-r--r-- apli/sym.c
33 # 2442 -rw-r--r-- apli/symt.c
34 # 1574 -rw-r--r-- apli/vec.c
35 # 14099 -rw-r--r-- apli/kernel.h
36 # 559 -rw-r--r-- apli/README
37 # 393 -rw-r--r-- apli/Makefile
38 #
42 ${md5check} || \
46 gettext_dir=FAILED
47 locale_dir=FAILED
50 do
53 then
56 esac
57 fi
60 then
62 fi
63 done
66 then
68 else
70 export TEXTDOMAINDIR
71 TEXTDOMAIN=sharutils
72 export TEXTDOMAIN
74 fi
78 '
81 f=shar-touch.$$
99 else
100 shar_touch=:
101 echo
104 echo
105 fi
107 #
111 fi
116 fi
117 # ============= apli/arith.c ==============
119 mkdir 'apli'
124 fi
125 fi
128 else
132 5.1 Arithmetic functions
133 arith.c
134 */
135 X
136 #include "kernel.h"
137 X
138 kerncell
140 {
144 X
150 X
154 X
156 X }
159 X
160 X kerncell
162 {
165 X
167 X
169 X
173 X
177 X
179 X }
181 X
183 X
184 X kerncell
186 {
189 X
192 X
196 X
197 X /*
198 X Arthmettc Stnngs and Symbols
199 X 68
200 X */
201 X
205 X
207 X }
209 X
211 X
212 X kerncell
214 {
217 X
219 X
224 X
228 X
230 X }
232 X
234 X
235 X kerncell
237 {
238 X
240 X
243 X register kerncell arg;
244 X
251 X }
252 X else
254 X }
257 X
259 X
261 X 5.1 Arithmetic functions
262 X */
263 X
264 X kerncell
266 {
267 X
269 X
272 X register kerncell arg;
273 X
275 X
281 X }
282 X else
284 X }
287 X
289 X
290 X kerncell
292 {
295 X
298 X
300 X
301 X
303 X Arithmetic, Strings und Symbols
304 X */
305 X
306 X kerncell
308 {
311 X double pow ();
312 X
314 X
316 X
318 X
320 X
321 X kerncell
323 {
324 X kerncell arg = ARGnum1;
325 X
326 X CHECKlargs (incsym, 1);
327 X return (mkinum(GETint (incsym, arg) + 1) );
328 X
329 } /* Linc */
330 X
331 X kerncell
333 {
335 X
337 X
340 X
342 X kerncell
344 {
345 X
346 X kerncell arg = ARGnum1;
347 X
348 X CHECKlargs (abssym, 1);
349 X
350 X if (ISint (arg) )
351 X return (arg->CELLinum >= 0 ? arg : mkinum(-arg->CELLinum) );
352 X
353 X if (ISreal (arg) )
354 X return (arg->CELLrnum >= 0 ? arg: mkrnum(-arg->CELLrnum) );
355 X
356 X error (abssym, err_num, arg);
357 X
358 } /* Labs */
359 X
360 X
361 X kerncell
363 {
366 X
369 X
372 X
375 X
376 X kerncell
378 {
379 X kerncell arg = ARGnum1;
380 X double floor ();
381 X
382 X CHECKlargs (intsym, 1);
383 X return (mkinum( (int) floor(GETreal(intsym, arg) + 0.0) ) );
384 X
385 } /* Lint */
386 X
387 /* 72 */
388 X kerncell
390 {
391 X
394 X
397 X
398 X kerncell
400 {
401 X
404 X
407 X
409 X
410 X kerncell
412 {
415 X
417 X
420 X
422 X 5.1 Arithmetic functions
423 X */
424 X
425 X kerncell
427 {
430 X
433 X
435 X
436 kerncell
437 X
439 {
442 X
444 X
446 X
448 X
449 X kerncell
451 {
454 X
457 X
459 X
460 X
461 X kerncell
463 {
466 X
468 X
471 X
472 X
473 X kerncell
475 {
476 X kerncell arg = ARGnum1;
477 X
478 X CHECKlargs( numberpsym, 1);
479 X
480 X return(ISint(arg) || ISreal(arg) ? TTT: NIL) ;
481 } /* Lnumberp */
482 X
483 /* 74
484 X Arithmetic, Strings and Symbols
485 X */
486 X
487 X
488 X kerncell
490 {
493 X
495 X
497 X
498 X kerncell
500 {
503 X
505 X
506 SHAR_EOF
511 fi
516 9197b8cca2085574a60fea8f7d8db733 apli/arith.c
517 SHAR_EOF
518 else
521 fi
522 fi
523 # ============= apli/cellt.c ==============
525 mkdir 'apli'
530 fi
531 fi
534 else
538 #include "kernel.h"
539 X
540 extern kerncell _tempstr;
541 extern kernsym symtab [];
550 kerncell collectgarb();
551 X
552 X char *
554 X int size;
555 {
557 X
561 X collectgarb();
562 X if ((res = (char *)malloc(size)) == NULL ) /* try again */
563 X faterr (err_memory);
564 X }
565 X
566 X return (res);
567 } /* new */
568 X
569 X
570 X
571 /* p22 */
572 initcelltab () /* initialize the cell table */
573 {
574 X int range = SMALLINTHIGH - SMALLINTLOW;
575 X register int blkidx;
576 X register kerncell blkptr;
577 X
578 X if (range >= BLOCKSIZE)
579 X faterr("BLOCKSIZE is too small" );
580 X
581 X if ( (celltab [celltabidx] = blkptr = inumblock =
582 X (kerncell) malloc (sizeof (struct cell) * BLOCKSIZE) ) == NULL)
583 X faterr (err_memory);
584 X
585 X for (blkidx=0; blkidx < range; ++blkidx) { /* small inums */
586 X blkptr->flag = INTOBJ;
587 X (blkptr++)->CELLinum = SMALLINTLOW + blkidx;
588 X }
589 X
590 X blockidx = blkidx;
591 X blockptr = blkptr + 1;
592 } /* initcelltab */
593 X
594 X
595 /* p23 */
596 X kerncell
597 freshcell () /* returns a fresh cons-cell */
598 {
599 X static kerncell freecell;
600 X if (phase1) { /* in this phase storage is still available */
601 X if (blockidx++ < BLOCKSIZE) { /* get it fran current block */
602 X blockptr->CELLcdr = NIL;
603 X return (CELLpush(blockptr++) );
604 X }
605 X if (++celltabidx < celltabsize) { /* create a new block */
606 X if ((celltab[celltabidx] = blockptr = (kerncell)
607 X malloc(sizeof(struct cell) * BLOCKSIZE)) == NULL) {
608 X celltabsize = celltabidx;
609 X goto phase2; /* run out of storage > phase2 */
610 X }
611 X blockidx = 1;
612 X blockptr->CELLcdr = NIL;
613 X return (CELLpush (blockptr++));
614 X }
615 phase2: /* in this phase storage is exhausted */
616 X phase1 = 0;
617 X }
618 X if (freelist == NULL)
619 X if (collectgarb() == NULL) /* try garbage collecting */
620 X faterr ("cons-cell storage exhausted");
621 X freecell = freelist;
622 X freelist = freelist->CELLcdr;
623 X freecell->CELLcdr = NIL;
624 X return (CELLpush ( freecell) );
625 } /* freshcell */
626 X
627 X
628 /* p24 Storage Management */
629 X
630 /* collect garbage */
631 X kerncell
632 collectgarb ()
633 {
634 X register int i, cidx;
635 X register kernsym entry;
636 X register kerncell blockptr;
637 X
638 X /**** mark ****/
639 X for (i<0; i < HASHTABSIZE; ++i) {
640 X entry = symtab [i];
646 X }
647 X }
648 X
654 X }
657 X
677 X }
679 X }
680 X }
681 X }
684 X
685 X
686 X
688 X
690 X register kerncell obj;
691 {
692 X
695 X ||
707 X }
714 X }
716 X mark (obj);
717 X return;
718 X default: /* mark elementary object */
719 X obj->flag != MARK;
720 X return;
721 X }
722 } /* mark */
723 X
724 X kerncell
725 mkinum(inum)
726 X int inum;
727 {
728 X /* make an integer object */
729 X kerncell obj;
730 X if (inum >= SMALLINTLOW && inum < SMALLINTHIGH)
731 X return (inumblock + inum - SMALLINTLOW);
732 X obj = freshcell();
733 X obj->flag = INTOBJ;
734 X obj->CELLinum = inum;
735 X return (obj);
736 } /* mkinum */
737 X
738 X
739 X
740 /* p27 */
741 X kerncell
742 mkrnum(rnum)
743 X real rnum;
744 {
745 X /* make a real object */
746 X kerncell obj = freshcell ();
747 X obj->flag = REALOBJ;
748 X obj->CELLrnum = rnum;
749 X return (obj);
750 } /* mkrnum */
751 X
752 X kerncell
753 mkstr (str) /* make a string object */
754 X char *str;
755 {
756 X kerncell obj = freshcell();
757 X char *newstr;
758 X int len = strlen(str);
759 X newstr = new(len + 1);
760 X strcpy (newstr, str );
761 X *(newstr + len) = 0;
762 X obj->flag = STROBJ;
763 X obj->CELLstr = newstr;
764 X return (obj);
765 } /* mkstr */
766 X
767 X kerncell
768 _mkstr (str)
769 X char *str;
770 {
771 X /* make a temporary string object */
772 X _tempstr->CELLstr = str;
773 X return ( _tempstr);
774 } /* mkstr */
775 X
776 X
777 /* p28 */
778 X kerncell
779 mkchan (chan) /* make a channel object */
780 X iochan chan;
781 {
782 X
783 X kerncell obj = freshcell ();
784 X obj->flag = CHANOBJ;
785 X obj->CELLchan = chan;
786 X return (obj);
787 } /* mkchan */
788 X
789 X kerncell
790 mkcell (head, tail) /* make a new cons-cell */
791 X kerncell head, tail;
792 {
793 X
794 X kerncell obj = freshcell();
795 X obj->flag = LISTOBJ;
796 X obj->CELLcar = head;
797 X obj->CELLcdr = tail;
798 X return (obj);
799 } /* mkcell */
800 X
801 X kerncell
802 mkset (head, tail) /* make a new cons-cell */
803 X kerncell head, tail;
804 {
805 X
806 X kerncell obj = freshcell();
807 X obj->flag = SETOBJ;
808 X obj->CELLcar = head;
809 X obj->CELLcdr = tail;
810 X return (obj);
811 } /* mkset */
812 SHAR_EOF
815 if test $? -ne 0
817 fi
819 then (
821 ) << SHAR_EOF
822 35ae0743768222234ecff982b5263c99 apli/cellt.c
823 SHAR_EOF
824 else
827 fi
828 fi
829 # ============= apli/eval.c ==============
832 else
835 /* eval.c */
836 X
837 #include "kernel.h"
838 X
839 extern kernsym evalsym;
840 extern error( kerncell, char*, kerncell);
841 kerncell evalcall (kerncell, kerncell, int );
842 kerncell evallam (kerncell, kerncell, int );
843 X
844 X kerncell
845 eval (expr) /* evaluate expr */
846 X kerncell expr;
847 {
848 X
849 X if (ISsym(expr)) {
850 X
851 X if ( ISconst(expr) || ISvar(expr) || ISinternal (expr) )
852 X return (CONVsym(expr)->bind);
853 X
854 X error( evalsym, "unbound symbol", EVALpush(expr));
855 X }
856 X else if (ISlist(expr) )
857 X
858 X { int save_celltop = celltop; /* save top of cell stack */
859 X
860 X kerncell save = evalcall (expr->CELLcar, EVALpush(expr), 0);
861 X EVALpop();
862 X celltop = save_celltop; /* restore top of cell stack */
863 X return(save);
864 X }
865 X else
866 X return (expr); /* any other object evaluates to itself */
867 } /* eval */
868 X
869 X
870 X
871 X kerncell
872 evalcall (head, list, stacked) /* evaluate a function call */
873 X register kerncell head, list;
874 X int stacked; /* non-zero when args are already stacked */
875 {
876 X kerncell fox;
877 X kerncell (* fun) ();
878 X
879 X int arg1;
880 X
881 start:
882 X if (ISlist(head)) { /* ((...) arg1 ... argn) */
883 X
884 X if ( (fox = head->CELLcar) == CONVcell(lamsym) )
885 X return (evallam(head, list->CELLcdr, stacked) );
886 X
887 X if (fox == CONVcell(vlamsym) )
888 X return (evalvlam(head, list->CELLcdr, stacked) );
889 X
890 X if (fox == CONVcell(ulamsym) )
891 X return (expand (head, list, stacked) );
892 X
893 X if (fox == CONVcell(mlamsym) )
894 X return (eval(expand (head, list, stacked) ) );
895 X
896 X head = evalcall (head->CELLcar, head, 0);
897 X }
898 X
899 X if (ISsym(head) ) { /* (head arg1 ... argn) */
900 X
901 X if (head == CONVcell (quotesym) ) /* < expr */
902 X return (list->CELLcdr->CELLcar);
903 X
904 X switch (head->flag) { /* what, kind of symbol is head? */
905 X case FUNCTION:
906 X head = CONVsym(head) ->bind; /* function binding */
907 X goto start;
908 X
909 X case LBINARY:
910 X case VBINARY:
911 X if (!stacked) {
912 X arg1 = argtop+1;
913 X list = list->CELLcdr;
914 X while (ISlist(list)) {
915 X fox = eval(list->CELLcar); /* evaluate args */
916 X ARGpush(fox); /* push args onto arg stack */
917 X list = list->CELLcdr;
918 X }
919 X ARGpush(CONVcell(arg1) ); /* push position of 1st arg */
920 X }
921 X fox = ((fun = CONVsym(head) ->bind) != CONVcell(Lcxxr)
922 X ? (* fun) ()
923 X : (* fun) (CONVsym(head) ->name));
924 X
925 X if (! stacked)
926 X ARGSpop();
927 X return (fox);
928 X
929 X case UBINARY:
930 X fox = (stacked ? mkargslist () : list->CELLcdr);
931 X ARGpush (fox);
932 X fun = CONVsym(head) ->bind;
933 X fox = (* fun) ();
934 X ARGpop();
935 X return (fox);
936 X
937 X case MBINARY:
938 X fox = (stacked ? mkargslist () : list->CELLcdr);
939 X ARGpush (fox);
940 X fun = CONVsym(head) ->bind;
941 X fox = (* fun) ();
942 X ARGpop();
943 X return(eval(stacked
944 X ? fox /* substitute the result */
945 X :(ISlist(fox)
946 X ? (list->CELLcar = fox->CELLcar,
947 X list->CELLcdr = fox->CELLcdr, list)
948 X :(list->CELLcar = CONVcell(voidsym),
949 X list->CELLcdr = mkcell (fox, nil)))));
950 X
951 X } /* switch */
952 X }
953 X if (ISvector(fox = head) || /* indexed vector? */
954 X ISvar (fox) && ISvector (fox = CONVsym(fox)->bind) )
955 X
956 X return (evalvector (fox, list->CELLcdr, stacked));
957 X
958 X error(evalsym, "undefined function", head);
959 X
960 } /* evalcall */
961 X
962 /* 36 */
963 kerncell
964 X
965 evallam (lam, args, stacked) /* evaluate a lam application */
966 X register kerncell lam, args;
967 X int stacked; /* non-zero when args are already stacked */
968 {
969 X int arg1, nvars;
970 X kerncell obj, vars;
971 X register kerncell vs;
972 X
973 X lam = lam->CELLcdr; /* drop lam head */
974 X
975 X if ((vars = lam->CELLcar) != NIL && ! ISlist(vars) )
976 X
977 X error (evalsym, err_pars,vars);
978 X
979 X nvars = checkvars (vars); /* check that vars are all symbols */
980 X
981 X if (!stacked) {
982 X
983 X arg1 = argtop + 1;
984 X
985 X while (ISlist (args) ) {
986 X obj = eval (args->CELLcar); /* evaluate each argument and */
987 X ARGpush(obj); /* push it onto arg stack */
988 X args = args->CELLcdr;
989 X }
990 X
991 X ARGpush (CONVcell (arg1) ); /* push position of 1st arg */
992 X
993 X } else
994 X arg1 = ARGidx1;
995 X
996 X CHECKlargs(lamsym, nvars); /* check number of args */
997 X savevars(vars); /* save current binding of vars */
998 X for (vs=vars; ISlist(vs); vs=vs->CELLcdr) /* bind the vars to args */
999 X
1000 X CONVsym(vs->CELLcar)->bind = argstk[arg1++];
1001 X obj = NIL;
1002 X lam = lam->CELLcdr;
1003 X
1004 X while (ISlist(lam) ) {
1005 X
1006 X obj= eval (lam->CELLcar); /* eval each form in lam body */
1007 X lam = lam->CELLcdr;
1008 X }
1009 X
1010 X restorevars (vars); /* restore the binding of vars */
1011 X
1012 X if(! stacked)
1013 X ARGSpop(); /* pop argutents */
1014 X return(obj); /* return the value of last form */
1015 } /* evallam */
1016 X
1017 /* 37 */
1018 X kerncell
1019 evalvlam (vlam, args, stacked) /* evaluate a vlam application */
1020 X register kerncell vlam, args;
1021 X int stacked; /* non-zero when args are already stacked */
1022 {
1023 X
1024 X int arg1, save_argtop = argtop; /* for nested vlam calls */
1025 X kerncell obj, vars;
1026 X
1027 X vlam = vlam->CELLcdr; /* drop vlam head */
1028 X
1029 X if (! ISlist(vars = vlam->CELLcar) || checkvars(vars) != 1)
1030 X error (evalsym, err_pars, vars);
1031 X
1032 X if (! stacked) {
1033 X arg1 = argtop+1;
1034 X while (ISlist (args) ) {
1035 X obj = eval (args->CELLcar); /* evaluate each argument and */
1036 X ARGpush (obj); /* push it onto arg stack */
1037 X args = args->CELLcdr;
1038 X }
1039 X
1040 X /* 38 */
1041 X ARGpush (CONVcell (arg1) );
1042 X
1043 X } else
1044 X arg1 = ARGidx1;
1045 X
1047 X savevars (vars); /* save current. binding of var */
1048 X /* var is set t,o the number of arguments: */
1049 X
1050 X CONVsym(vars->CELLcar)->bind = mkinum(argtop - arg1);
1051 X obj = NIL;
1052 X
1053 X vlam = vlam->CELLcdr;
1054 X
1055 X while (ISlist(vlam)) {
1056 X obj = eval(vlam->CELLcar); /* eval each form in vlam body */
1057 X vlam = vlam->CELLcdr;
1058 X }
1059 X restorevars(vars); /* restore argtop */
1060 X _argtop = save_argtop; /* restore the binding of var */
1061 X
1062 X if (! stacked)
1063 X ARGSpop (); /* pop arguments */
1064 X
1065 X return (obj); /* retrunr the value of last form */
1066 X
1067 } /* evalvlam */
1068 X
1069 /* 39
1070 X 3.2 Internal evaluation functions
1071 X */
1072 X
1073 kerncell
1074 X
1075 expand (fun, list, stacked) /* expand ulam/mlam application */
1076 X register kerncell fun;
1077 X kerncell list;
1078 X int stacked;
1079 {
1080 X kerncell fox, vars;
1081 X
1082 X int ismacro = fun->CELLcar == CONVcell(mlamsym);
1083 X
1084 X fun = fun->CELLcdr; /* drop ulam/mQam */
1085 X
1086 X if ( !ISlist(vars = fun->CELLcar) || checkvars (vars) != 1)
1087 X error (evalsym, err_pars , vars);
1088 X
1089 X /* the list of arguments is treated as 1 arg: */
1090 X fox = (stacked ? mkargslist (): list->CELLcdr);
1091 X ARGpush (fox);
1092 X
1093 X savevars (vars);
1094 X
1095 X CONVsym(vars->CELLcar) ->bind = argstk [argtop];
1096 X
1097 X fox = NIL;
1098 X
1099 X fun = fun->CELLcdr;
1100 X
1101 X while (ISlist (fun) ) { /* evaluate body */
1102 X
1103 X fox = eval (fun->CELLcar);
1104 X
1105 X fun = fun->CELLcdr;
1106 X }
1107 X
1108 X restorevars (vars);
1109 X ARGpop();
1110 X
1111 X return(ismacro && !stacked
1112 X ? (ISlist (fox) /* substitute the result */
1113 X ? (list->CELLcar = fox->CELLcar,
1114 X list->CELLcdr = fox->CELLcdr, list)
1115 X : (list->CELLcar = CONVcell (voidsym),
1116 X list->CELLcdr = mkcell(fox,nil), list))
1117 X : fox);
1118 X
1119 } /* expand */
1120 X
1121 X kerncell
1122 evalvector (head, tail, stacked) /* vector application */
1123 X kerncell head, tail;
1124 X int stacked; /* non-zero when args are already stacked */
1125 X
1126 {
1127 X kerncell index;
1128 X
1129 X if (stacked ? (argtop - ARGidx1 != 1 || !ISint(index = ARGnum1))
1130 X :(tail == NIL ) || tail->CELLcdr != nil
1131 X || !ISint (index = eval (tail->CELLcar)))
1132 X
1133 X error (evalsym, "bad vector index", index);
1134 X
1135 X if (index->CELLinum < 0 ||
1136 X index->CELLinum >= head->CELLdim->CELLinum)
1137 X error (evalsym, "vector index out of range", index);
1138 X
1139 X if (stacked)
1140 X ARGSpop();
1141 X
1142 X return (* (head->CELLvec + index->CELLinum) );
1143 } /* mralvector */
1144 X
1145 /* 40 */
1146 checkvars (vars) /* check that elements of vars are all symbols */
1147 X register kerncell vars; /* returns the length of the vars list */
1148 {
1149 X int count = 0;
1150 X
1151 X while (ISlist (vars) ) {
1152 X ++count;
1153 X
1154 X if (!ISsym(vars->CELLcar) || ISconst(vars->CELLcar))
1155 X
1156 X error (evalsym, err_pars, vars->CELLcar );
1157 X
1158 X vars = vars->CELLcdr;
1159 X }
1160 X return (count);
1161 } /* checkvars */
1162 X
1163 savevars (vars) /* save the bindings of vars in varstk */
1164 X register kerncell vars;
1165 {
1166 X
1167 X register kernsym var;
1168 X
1169 X while (ISlist (vars) ) {
1170 X
1171 X var = CONVsym(vars->CELLcar);
1172 X
1173 X /* NOTE: property lists are not stacked: */
1174 X
1175 X VARpush(var, var->flag, var->bind);
1176 X
1177 X var->flag = VARIABLE;
1178 X
1179 X vars = vars->CELLcdr;
1180 X }
1181 } /* savevars */
1182 X
1183 restorevars (vars) /* restore the binding of variables */
1184 X register kerncell vars;
1185 {
1186 X
1187 X while (ISlist(vars) ) {
1188 X VARpop();
1189 X
1190 X vars = vars->CELLcdr;
1191 X }
1192 } /* restorevars */
1193 X
1194 X
1195 /* 41 */
1196 X
1197 X kerncell
1198 mkargslist () /* make an argument list using the entries on argstk */
1199 {
1200 X
1201 X register int argi = ARGidx1;
1202 X register kerncell arglist = NIL, list;
1203 X
1204 X while (argi < argtop)
1205 X if (arglist == NIL)
1206 X arglist = list = mkcell(argstk[argi++],nil);
1207 X else
1208 X list = list->CELLcdr = mkcell(argstk[argi++],nil);
1209 X
1210 X return(arglist);
1211 X
1212 } /* mkargslist */
1213 X
1214 X kerncell
1216 {
1217 X
1220 X
1222 X
1224 X
1225 X kerncell
1227 {
1228 X
1229 X kerncell fox;
1230 X
1231 X CHECKvargs1 (callsym, 1);
1232 X
1233 X fox = ARGnum1; /* the function to be called */
1234 X
1235 X argstk[argtop] = CONVcell(CONVint(argstk[argtop]) + 1);
1236 X
1237 X fox = evalcall(fox,nil,1); /* do the call */
1238 X
1239 X argstk [argtop] = CONVcell (CONVint (argstk [argtop] ) - 1);
1240 X
1241 X return (fox);
1242 X
1243 } /* Vcall */
1244 X
1245 X kerncell
1247 {
1248 X
1249 X kerncell arg1 = ARGnum1;
1250 X
1251 X register kerncell arg2 = ARGnum2;
1252 X kerncell fox = CONVcell (argtop + 1);
1253 X
1254 X CHECKlargs (applysym, 2);
1255 X CHECKlist (applysym, arg2);
1256 X
1257 X while (ISlist (arg2) ) { /* stack the arguments */
1258 X
1259 X ARGpush(arg2->CELLcar);
1260 X
1261 X arg2 = arg2->CELLcdr;
1262 X }
1263 X
1264 X ARGpush (fox);
1265 X fox = evalcall(arg1, nil, 1);
1266 X ARGSpop();
1267 X
1268 X return ( fox);
1269 X
1270 } /* Lapply */
1271 SHAR_EOF
1274 if test $? -ne 0
1276 fi
1278 then (
1280 ) << SHAR_EOF
1281 5b97d37d7998cf9151cf5750dd48dee8 apli/eval.c
1282 SHAR_EOF
1283 else
1286 fi
1287 fi
1288 # ============= apli/flow.c ==============
1291 else
1294 /* 118 ItIonstandard Flow of Control and Iteratton */
1295 /* flow.c */
1296 X
1297 #include "kernel.h"
1298 #include <setjmp.h>
1299 X
1300 #define CATpush() \
1301 X if (++cattop < CATSTKSIZE) { \
1302 X catstk[cattop].evaltop = evaltop; \
1303 X catstk[cattop].celltop = celltop; \
1304 X catstk[cattop].vartop = vartop; \
1305 X catstk[cattop].argtop = argtop; \
1306 X catstk[cattop]._argtop = _argtop; \
1307 X } else faterr(err_catstk) ;
1308 X
1309 #define CATpop() --cattop
1310 X
1311 struct catframe { /* catch frame */
1312 X jmp_buf jmp; /* for setjmp and longjmp */
1313 X int evaltop; /* evaltop at the tirade of setjmp */
1314 X int celltop; /* celltop at the tine of setjmp */
1315 X int vartop; /* vartop at the timbre of setjmp */
1316 X int argtop; /* argtop at the tim of setjmp */
1317 X int _argtop; /* argtop of the last vlam */
1318 };
1319 X
1320 struct catframe catstk[CATSTKSIZE]; /* the catch stack */
1321 int cattop = -1; /* top of jump stack */
1322 int errtrap = 0; /* no error capture when zero */
1323 int errshow = 1; /* errors are reported when -non-zero */
1324 int errocc = 0; /* set when an error occurs */
1325 int level = 0; /* kernel level */
1326 X
1327 X kerncell
1329 {
1330 X kerncell list = argstk [argtop];
1331 X
1332 X if (list == NIL || list->CELLcdr != NIL)
1333 X error (catchsym, err_args,0);
1334 X
1335 X return(catch (list->CELLcar, eval(list->CELLcdr->CELLcar),NULL));
1336 } /* Ucatch */
1337 X
1338 X
1339 /* 119 9.1 Nonstandard flo~ of control
1340 */
1341 X kerncell
1342 catch (expr, tag, more) /* catch throws during evaluation */
1343 X kerncell expr, tag;
1344 X word more;
1345 {
1346 X
1347 X CATpush();
1348 X
1349 X /* get ready for throws: */
1350 X int res = setjmp(catstk[cattop].jmp);
1351 X
1352 X if ( !CONVcell( res )) {
1353 X if (more.i)
1354 X {
1355 X kerncell (* cfun) () = expr;
1356 X expr = (* cfun) (); /* cfun may have throws */
1357 X
1358 X expr = (* cfun) (more); /* cfun may have throws */
1359 X }
1360 X else {
1361 X expr = eval(expr); /* expr may contain throws */
1362 X }
1363 X }
1364 X else if (tag == NIL
1365 X && !ISinternal(CONVsym(catres->CELLcar))
1366 X || catres->CELLcar == NIL
1367 X && !ISinternal(tag)
1368 X && !ISlist (tag)
1369 X || catres->CELLcar == tag
1370 X || ISlist (tag)
1371 X && memq(catres->CELLcar, tag)) {
1372 X
1373 // DBG("catch 20")
1374 X cleanup ();
1375 X
1376 X CATpop (); /* catch the throw and */
1377 X
1378 X return (catres->CELLcdr); /* return its result */
1379 X }
1380 // DBG("catch 30")
1381 X else if (cattop < 1) /* one catch is reserved for top level */
1382 X error(catchsym,"no catch for this tag",catres->CELLcar);
1383 X else {
1384 X cleanup();
1385 X
1386 X longjmp (catstk [CATpop () ] . jmp, catres); /* try another catch */
1387 X }
1388 X DBG("end catch")
1389 X CATpop(); /* there was no throw, so ignore the catch */
1390 X return (expr);
1391 } /* catch */
1392 X
1393 X
1394 /* 120 Nonstandard Flow of Control and IteraMn */
1395 cleanup () /* clean up stacks after a throw */
1396 {
1397 X register int vtop = catstk[cattop].vartop;
1398 X
1399 X while (vtop < vartop) /* restore non-global vars */
1400 X VARpop();
1401 X
1402 X evaltop = catstk[cattop].evaltop; /* restore eval stack */
1403 X celltop = catstk[cattop].celltop; /* restore eval stack */
1404 X argtop = catstk[cattop].argtop; /* restore arg stack */
1405 X _argtop = catstk[cattop]._argtop; /* restore _argtop */
1406 } /* cleanup */
1407 X
1408 X
1409 X kerncell
1411 {
1412 X CHECKvargs (throwsym, 1,2);
1413 X
1414 X return(throw(ARGnum1, (argtop - ARGidx1 == 1 ? NIL: ARGnum2) ) ) ;
1415 X
1416 } /* Vthrow */
1417 X
1418 X
1419 X kerncell
1420 throw (expr,tag) /* evaluate and throw expr, plus its tag */
1421 X kerncell expr, tag;
1422 {
1423 X
1424 X catres->CELLcar = tag;
1425 X catres->CELLcdr = expr;
1426 X longjmp(catstk[cattop].jmp, catres);
1427 } /* throw */
1428 X
1429 X
1430 X
1431 /* 121 kl Nonstandard flow of control */
1432 X
1433 X kerncell
1435 {
1437 X
1440 X
1443 X
1444 X
1445 X kerncell
1449 {
1450 X
1454 X kerncell res;
1455 X
1457 X
1459 X
1461 X
1463 X
1465 X
1467 X
1469 X
1471 X
1473 X
1475 X
1477 X kerncell
1479 {
1480 X kerncell arg2;
1481 X
1483 X CHECKvargs (errorsym, 2, 3);
1485 X
1486 X arg2 = ARGnum2;
1487 X
1488 X error (ARGnum1, GETstr (errorsym, arg2),
1489 X (argtop == ARGidx1 == 2 ? 0 : ARGnum3)) ;
1490 X
1491 X return (TTT);
1492 X
1493 } /* Verror */
1494 X
1495 error (source, message, extra) /* error handling routine */
1496 X kerncell source;
1497 X char *message;
1498 X kerncell extra;
1499 {
1500 X errocc = 1 ; /* set error flag */
1501 X
1502 X /* 123 9.l Nonstandard flow of control */
1503 X if (errshow) { /* error to be shown? */
1504 X bufprint(PRINT, _outchan, "ERROR, ");
1505 // bufprint(PRINT, _errchan,"ERROR, ");
1506 X
1507 X if (source != 0) {
1508 X
1509 X PRINTchan (source, errchan);
1510 X bufprint (PRINT, _errchan, ": ");
1511 X }
1512 X
1513 X bufprint (PRINT, _errchan, "%s", message);
1514 X
1515 X if (extra != 0) {
1516 X
1517 X bufprint (PRINT, _errchan,": ", 0);
1518 X
1519 X PRINTchan (extra, errchan);
1520 X }
1522 X }
1523 X if (errtrap) /* error to be trapped? */
1524 X {
1525 X throw (NIL, _errtagsym); /* throw this to the catch of capexx */
1526 X }
1527 X else
1528 X EVALpush (CONVcell (errorsym) );
1529 X
1530 X errlevel (); /* enter error level */
1531 } /* error */
1532 X
1534 {
1535 X kerncell obj;
1536 X
1538 X
1540 X
1542 X
1544 X
1546 X
1549 X }
1550 X
1553 X }
1555 X
1558 {
1561 X
1563 X
1564 X
1565 X
1567 X
1568 X
1570 {
1573 X
1575 X
1577 X
1579 X
1580 X
1582 X
1584 X }
1586 X
1587 X kerncell
1589 {
1590 X kerncell obj;
1591 X
1593 X
1595 X
1597 X
1598 X
1601 X
1603 X }
1604 X
1607 X }
1609 X
1610 X
1611 X
1612 X kerncell
1614 {
1617 X
1619 X
1620 X kerncell
1622 {
1623 X kerncell arg;
1624 X
1625 X int idx1 = ARGidx1;
1626 X int exitcode = 0;
1627 X
1628 X CHECKvargs2 (exitsym, 1);
1629 X if (argtop == idx1 + 1) {
1630 X
1631 X arg = ARGnum1;
1632 X
1633 X exitcode = GETint(exitsym, arg);
1634 X }
1635 X exit (exitcode);
1636 X
1637 } /* Vexit */
1638 X
1639 X
1640 SHAR_EOF
1643 if test $? -ne 0
1645 fi
1647 then (
1649 ) << SHAR_EOF
1650 ac1362c7e755a6cfe38820bb142d8de0 apli/flow.c
1651 SHAR_EOF
1652 else
1655 fi
1656 fi
1657 # ============= apli/globals.c ==============
1660 else
1663 /* g1obals.c */
1664 #include "kernel.h"
1665 char *err_args = "incorrect number of arguments";
1666 char *err_pars = "bad parameter(s)";
1667 char *err_evalstk = "evaluation stack overflow";
1668 char *err_varstk = "variable stack overflow";
1669 char *err_argstk = "arguxrent stack overflow" ;
1670 char *err_catstk = "catch stack overflow";
1671 char *err_memory = "memory space exhausted";
1672 char *err_int = "integer number expected" ;
1673 X
1674 /* p167 */
1675 X
1676 char *err_real = "real nurber expected";
1677 char *err_num = "number expected";
1678 char *err_str = "string expected";
1679 char *err_chan1 = "channel expected";;
1680 char *err_chan2 = "bad channel";
1681 char *err_sym1 = "symbol expected" ;
1682 char *err_sym2 = "non-constant syrrbol expected";
1683 char *err_pair = "non-nil list expected";
1684 char *err_list = "list expected";
1685 char *err_var = "bad variable";
1686 char *err_dom = "bad domain designator";
1687 X
1688 kerncell catres; /* catch result pair */
1689 kerncell golabel; /* label specified by go in prog */
1690 kerncell _tempstr;
1691 kerncell read_and_eval, top_lev_call, top_lev_tags;
1692 kerncell inchan, outchan, errchan;
1693 iochan _inchan, _outchan, _errchan;
1694 char strbuf [STRBUFSIZE+2] ; /* string buffer */
1695 struct variable varstk[VARSTKSIZE+1] ; /* variable stack */
1696 kerncell evalstk [EVALSTKSIZE+1]; /* evaluation stack (also cell stack) */
1697 X
1698 kerncell argstk[ARGSTKSIZE+1]; /* argument stack */
1699 int evaltop = -1; /* top of evaluation stack */
1700 int celltop = EVALSTKSIZE; /* top of cell stack */
1701 int vartop = -1; /* top of variable stack */
1702 int argtop = -1; /* top of argument stack */
1703 int _argtop = -1; /* argtop for the last vlam */
1704 int (* org_interrupt) () ; /* original interrupt handler */
1705 X
1706 kernsym /* internals: */
1707 _bquotesym, _commasym, _atsym,
1708 _toptagsym, _errtagsym, _rettagsym, _gotagsym, _tempsym, _cxxrsym;
1709 X
1710 kernsym /* constants: */
1711 nil, ttt, eofsym, inchansym, outchansym, errchansym;
1712 X
1713 kernsym /* unbounds: */
1714 lamsym, vlamsym, ulamsym, mlamsym;
1715 X
1716 kernsym /* eval.c: */
1717 evalsym, callsym, applysym;
1718 X
1719 kernsym /* io.c: */
1720 opensym, closesym, flushsym, readsym, printsym, princsym, tabsym,
1721 X terprisym, prlensym, iobufsym, chanpsym, ppsym;
1722 X
1723 kernsym /* arith.c: */
1724 plussym, minussym, timessym, divsym, sumsym, prodsym, remsym,
1725 X powsym, incsym, decsym, abssym, negsym, intsym,realsym,
1726 X a_ltsym, a_gtsym, a_lesym,a_gesym, a_eqsym, a_nesym,
1727 X numberpsym, intpsym, realpsym;
1728 X
1729 kernsym /* str.c: */
1730 s_ltsym, s_gtsym, s_eqsym, strcmpsym, nthcharsym, substrsym,
1731 X strlensym, strconcsym, nilstrpsym, stringpsym;
1732 X
1733 kernsym /* sym.c: */
1734 symnamesym, synonymsym, gensymsym, concatsym, bindingsym,
1735 X
1736 X /* p.168 */
1737 X
1738 X /* Appendix A */
1739 X
1740 X symbolpsym, boundpsym;
1741 X
1742 X kernsym /* list.c: */
1743 X carsym, cdrsym, nthelemsym, nthpairsym, rplacasym, rplacdsym,
1744 X lastelemsym, lastpairsym, conssym, listsym, lengthsym, concsym,
1745 X dconcsym, removesym, dremovesym, substsym, dsubstsym, reversesym,
1746 X dreversesym, membersym, memqsym, equalsym, nequalsym, eqsym, neqsym,
1747 X atompsym, listpsym, pairpsym, nullpsym;
1748 X
1749 kernsym /* set.c: */
1750 convsetsym, dconvsetsym, convlistsym, dconvlistsym,
1751 X esetsym, isetsym, unionsym, intsecsym, diffsym, subsetsym;
1752 X
1753 kernsym /* logic.c: */
1754 notsym, andsym, orsym, condsym, implysym, equivsym,
1755 X allsym, existsym, onesym;
1756 X
1757 kernsym /* prop.c: */
1758 putpropsym, rempropsym, getsym, plistsym, setplistsym,
1759 X assocsym, assqsym;
1760 X
1761 kernsym /* vec.c: */
1762 vectorsym, storesym, dimensionsym, vectorpsym;
1763 X
1764 kernsym /* flow.c: */
1765 catchsym, throwsym, caperrsym, errorsym, toplevelsym,
1766 X resetsym, exitsym;
1767 X
1768 kernsym /* iter.c: */
1769 progsym, gosym, returnsym, dosym;
1770 X
1771 kernsym /* map.c: */
1772 mapcarsym, mapasym, mapcdrsym, mapdsym;
1773 X
1774 kernsym /* misc.c: */
1775 voidsym, quotesym, kwotesym, defsym, funsym, argsym, letsym,
1776 X setsym, setqsym, constsym, sssym, loadsym, shellsym;
1777 X
1778 SHAR_EOF
1781 if test $? -ne 0
1783 fi
1785 then (
1787 ) << SHAR_EOF
1788 1f5dd1b3cb2b752a411c792c50201df6 apli/globals.c
1789 SHAR_EOF
1790 else
1793 fi
1794 fi
1795 # ============= apli/init.c ==============
1798 else
1801 /* 143
1802 init.c
1803 */
1804 X
1805 #include "kernel.h"
1806 X
1807 #ifdef UNIX
1808 #include <signal.h>
1809 void _interrupt()
1810 {
1811 X error(0, "interrupted - to exit type (exit)", 0);
1812 } /* interrupt */
1813 #endif UNIX
1814 X
1815 initialize ()
1816 {
1817 X initcelltab();
1818 X initsymtab();
1819 X initio();
1820 X
1821 X catres = mkcell(nil, nil); /* catch result pair */
1822 X
1823 X /* internals: */
1824 X
1825 X _bquotesym = CONVsym(&_bquotesym);
1826 X _commasym = CONVsym(&_commasym);
1827 X _atsym = CONVsym(&_atsym);
1828 X
1829 X INTERNALsym(_toptagsym); _toptagsym->bind = CONVcell (_toptagsym);
1830 X INTERNALsym(_errtagsym); _errtagsym->bind = CONVcell (_errtagsym);
1831 X INTERNALsym(_rettagsym); _rettagsym->bind = CONVcell (_rettagsym);
1832 X INTERNALsym(_gotagsym); _gotagsym->bind = CONVcell (_gotagsym);
1833 X INTERNALsym(_tempsym); _tempsym->bind = CONVcell (_tempsym);
1834 X INTERNALsym(_cxxrsym); _cxxrsym->name = "c..r";
1835 X
1836 X _tempstr = mkstr("");
1837 X
1838 X /* constants: */
1839 X nil = newsym("nil", CONSTANT,0); nil->bind = nil->prop = NIL;
1840 X ttt = newsym("t", CONSTANT,0); ttt->bind = TTT;
1841 X eofsym = newsym("eof", CONSTANT,0); eofsym->bind = CONVcell (eofsym);
1842 X
1843 X inchansym = newsym("inchan", CONSTANT, inchan);
1844 X outchansym = newsym ("outchan", CONSTANT, outchan);
1845 X errchansym = newsym("errchan", CONSTANT, errchan);
1846 X /* unbounds: */
1847 X
1848 X /* 144
1849 X initialization, Integration and Compilation
1850 X */
1851 X
1852 X lamsym = newsym("1am", UNBOUND, nil);
1853 X vlamsym = newsym("vlam" , UNBOUND, nil);
1854 X ulamsym = newsym("ulam" , UNBOUND, nil) ;
1855 X mlamsym = newsym("mlam", UNBOUND, nil);
1856 X
1857 X /* eval.c: */
1858 X evalsym = newsym("eval", LBINARY, Leval);
1859 X callsym = newsym("call", VBINARY, Vcall);
1860 X applysym = newsym("apply", LBINARY, Lapply);
1861 X
1862 X /* io.c: */
1863 X opensym = newsym("open", LBINARY, Lopen);
1864 X closesym = newsym("close", LBINARY, Lclose);
1865 X flushsym = newsym("flush", VBINARY, Vflush);
1866 X readsym = newsym("read", VBINARY, Vread);
1867 X printsym = newsym("print", VBINARY, Vprint);
1868 X princsym = newsym("princ", VBINARY, Vprinc);
1869 X tabsym = newsym("tab", VBINARY, Vtab);
1870 X terprisym = newsym("terpri", VBINARY, Vterpri);
1871 X prlensym = newsym("prlen", VBINARY, Vprlen);
1872 X iobufsym = newsym("iobuf", VBINARY, Viobuf);
1873 X chanpsym = newsym("chan?", LBINARY, Lchanp);
1874 X ppsym = newsym("pp", VBINARY, Vpp);
1875 X
1876 X /* arith.c: */
1877 X plussym = newsym("+", LBINARY,Lplus);
1878 X minussym = newsym("-", LBINARY,Lminus);
1879 X timessym = newsym("*", LBINARY, Ltimes);
1880 X divsym = newsym("/", LBINARY, Ldiv);
1881 X sumsym = newsym("sum", VBINARY,Vsum);
1882 X prodsym = newsym("prod",VBINARY, Vprod);
1883 X remsym = newsym("%", LBINARY, Lrem);
1884 X powsym = newsym("^", LBINARY, Lpow);
1885 X incsym = newsym("++", LBINARY, Linc);
1886 X decsym = newsym("--", LBINARY, Ldec);
1887 X abssym = newsym("abs", LBINARY, Labs);
1888 X negsym = newsym("neg", LBINARY, Lneg);
1889 X intsym = newsym("int", LBINARY, Lint);
1890 X realsym = newsym("real", LBINARY, Lreal);
1891 X a_ltsym = newsym("<", LBINARY,La_lt);
1892 X a_gtsym = newsym(">", LBINARY,La_gt);
1893 X a_lesym = newsym("<=", LBINARY,La_le);
1894 X a_lesym = newsym("> ", LBINARY,La_ge);
1895 X a_eqsym = newsym("=", LBINARY, La_eq);
1896 X a_nesym = newsym("/=", LBINARY, La_ne);
1897 X numberpsym = newsym("number?", LBINARY, Lnumberp);
1898 X intpsym = newsym("int?", LBINARY,Lintp);
1899 X realpsym = newsym("real?", LBINARY, Lrealp);
1900 X
1901 X /* str.c: */
1902 X s_ltsym = newsym("<<", LBINARY, Ls_lt);
1903 X s_gtsym = newsym(">>", LBINARY, Ls_gt);
1904 X s_eqsym = newsym("==", LBINARY, Ls_eq);
1905 X strcmpsym = newsym("strcmp", LBINARY, Lstrcmp);
1906 X nthcharsym = newsym("nthchar", LBINARY, Lnthchar);
1907 X substrsym = newsym("substr", LBINARY, Lstrlen);
1908 X strlensym = newsym("strlen", LBINARY, Lstrlen);
1909 X strconcsym = newsym("strconc", LBINARY, Lstrconc);
1910 X nilstrpsym = newsym("nilstrp", LBINARY, Lnilstrp);
1911 X stringpsym = newsym("string?", LBINARY, Lstringp) ;
1912 X
1913 X /* sym.c: */
1914 X
1915 X /* 145
1916 X 11.1 Initialization
1917 X */
1918 X
1919 X symnamesym = newsym("symname", LBINARY, Lsymname);
1920 X synonymsym = newsym("synonym", UBINARY, Usynonym);
1921 X gensymsym = newsym("gensym", LBINARY, Lgensym);
1922 X concatsym = newsym("concat", VBINARY, Vconcat);
1923 X bindingsym = newsym("binding", LBINARY, Lbinding);
1924 X symbolpsym = newsym("symbol?", LBINARY, Lsymbolp);
1925 X boundpsym = newsym("Mund?", LBINARY, Lboundp);
1926 X
1927 X /* list.c: */
1928 X carsym = newsym("car", LBINARY,Lcar);
1929 X cdrsym = newsym("cdr", LBINARY, Lcdr);
1930 X nthelemsym = newsym("nthelem", LBINARY, Lnthelem);
1931 X nthpairsym = newsym("nthpair", LBINARY, Lnthpair);
1932 X rplacasym = newsym("rplaca", LBINARY, Lrplaca);
1933 X rplacdsym = newsym("rplacd", LBINARY,Lrplacd);
1934 X lastelemsym = newsym("lastelem", LBINARY, Llastelem);
1935 X lastpairsym = newsym("lastpair", LBINARY, Llastpair);
1936 X conssym = newsym("cons", LBINARY, Lcons);
1937 X listsym = newsym("list", VBINARY,Vlist);
1938 X lengthsym = newsym("length", LBINARY, Llength);
1939 X concsym = newsym("conc", VBINARY,Vconc);
1940 X dconcsym = newsym("*conc", VBINARY,Vdconc);
1941 X removesym = newsym("rerreve", LBINARY,Lremove);
1942 X dremovesym = newsym("*rermve", LBINARY,Ldremove);
1943 X substsym = newsym("subst", LBINARY,Lsubst);
1944 X dsubstsym = newsym("*subst", LBINARY,Ldsubst);
1945 X reversesym = newsym("reverse", LBINARY,Lreverse);
1946 X dreversesym = newsym("reverse", LBINARY,Ldreverse);
1947 X membersym = newsym("member", LBINARY, Lmember);
1948 X memqsym = newsym("memq", LBINARY, Lmemq);
1949 X equalsym = newsym("equal", LBINARY, Lequal);
1950 X nequalsym = newsym("nequal", LBINARY, Lnequal);
1951 X eqsym = newsym("eq", LBINARY, Leq);
1952 X neqsym = newsym("neq", LBINARY, Lneq);
1953 X atompsym = newsym("atom?", LBINARY, Latomp);
1954 X listpsym = newsym("list?", LBINARY, Llistp);
1955 X pairpsym = newsym("pair?", LBINARY, Lpairp);
1956 X nullpsym = newsym("null?", LBINARY, Lnullp);
1957 X
1958 X /* set.c: */
1959 X convsetsym = newsym("convset", LBINARY, Lconvset);
1960 X dconvsetsym = newsym("*convset", LBINARY, Ldconvset);
1961 X convlistsym = newsym("convlist", LBINARY, Lconvlist);
1962 X dconvlistsym = newsym("*convlist", LBINARY, Ldconvlist);
1963 X esetsym = newsym("eset", VBINARY, Veset);
1964 X isetsym = newsym("iset", UBINARY,Uiset);
1965 X unionsym = newsym("union", VBINARY,Vunion);
1966 X intsecsym = newsym("intsec", VBINARY,Vintsec);
1967 X diffsym = newsym("diff", LBINARY,Ldiff);
1968 X subsetsym = newsym("subset", LBINARY, Lsubset);
1969 X
1970 X /* logic.c: */
1971 X notsym = newsym("not", LBINARY,Lnot);
1972 X andsym = newsym("and", UBINARY,Uand);
1973 X orsym = newsym("or", UBINARY,Uor);
1974 X condsym = newsym("cond", UBINARY,Ucond);
1975 X implysym = newsym("imply", UBINARY,Limply);
1976 X equivsym = newsym("equiv", UBINARY,Lequiv);
1977 X allsym = newsym("all", UBINARY,Uall);
1978 X existsym = newsym("exist", UBINARY,Uexist);
1979 X
1980 X
1981 X /* 146
1982 X Initialization, Integration and Compilation
1983 X */
1984 X onesym = newsym("one", UBINARY, Uone);
1985 X
1986 X /* prop.c */
1987 X putpropsym = newsym("putprop", LBINARY, Lputprop);
1988 X rempropsym = newsym("remprop", LBINARY, Lremprop);
1989 X getsym = newsym("get", LBINARY, Lget);
1990 X plistsym = newsym("plist", LBINARY, Lplist);
1991 X setplistsym = newsym("setplist", LBINARY, Lsetplist);
1992 X assocsym = newsym("assoc", LBINARY, Lassoc);
1993 X assqsym = newsym("assq", LBINARY,Lassq);
1994 X
1995 X /* vec.c: */
1996 X vectorsym = newsym("vector", LBINARY, Lvector);
1997 X storesym = newsym("store", UBINARY,Ustore);
1998 X dimensionsym = newsym("dimension",LBINARY,Ldimension);
1999 X vectorpsym = newsym("vector?", LBINARY,Lvectorp);
2000 X
2001 X /* flow.c: */
2002 X catchsym = newsym("catch", UBINARY,Ucatch);
2003 X throwsym = newsym("thrower", VBINARY,Vthrow);
2004 X caperrsym = newsym("caperr", UBINARY, Ucaperr);
2005 X errorsym = newsym("error", VBINARY, Verror);
2006 X toplevelsym= newsym("toplevel", LBINARY, Ltoplevel);
2007 X resetsym = newsym("reset", LBINARY, Lreset);
2008 X exitsym = newsym("exit", VBINARY,Vexit);
2009 X
2010 X /* iter.c: */
2011 X progsym = newsym("prog", UBINARY, Uprog);
2012 X gosym = newsym("go", UBINARY, Ugo);
2013 X returnsym = newsym("return", VBINARY,Vreturn);
2014 X dosym = newsym("do", UBINARY, Udo);
2015 X
2016 X /* map.c: */
2017 X mapcarsym = newsym("mapcar", VBINARY,Vmapcar);
2018 X mapasym = newsym("mapa", VBINARY,Vmapa);
2019 X mapcdrsym = newsym("mapcdr", VBINARY,Vmapcdr);
2020 X mapdsym = newsym("mapd", VBINARY, Vmapd);
2021 X
2022 X /* misc c */
2023 X voidsym = newsym("void", UBINARY,Uvoid);
2024 X quotesym = newsym("quote", UBINARY, Uquote);
2025 X kwotesym = newsym("kwote", LBINARY, Lkwote);
2026 X defsym = newsym("def", UBINARY, Udef );
2027 X argsym = newsym("arg", LBINARY, Larg);
2028 X letsym = newsym("let", MBINARY,Mlet);
2029 X setsym = newsym("set", LBINARY, Lset);
2030 X setqsym = newsym("setq", UBINARY, Usetq);
2031 X constsym = newsym("const", UBINARY, Uconst);
2032 X sssym = newsym("ss", VBINARY, Vss);
2033 X loadsym = newsym("load", VBINARY,Vload);
2034 X
2035 #ifdef UNIX
2036 X shellsym = newsym("!", UBINARY, Ushell);
2037 #endif UNIX
2038 X
2039 X /* globals: */
2040 X
2041 X read_and_eval = mkcell(evalsym,mkcell(mkcell(readsym, nil), nil));
2042 X top_lev_call = mkcell(toplevelsym, nil);
2043 X top_lev_tags = mkcell(_toptagsym, mkcell(_errtagsym, nil));
2044 X
2045 #ifdef UNIX
2046 X org_interrupt = signal(SIGINT, SIG_IGN);
2047 X signal(SIGINT, _interrupt);
2048 #endif UNIX
2049 X
2050 } /* initialize */
2051 /*
2052 #ifdef UNIX
2053 #include <signal.h>
2054 _interrupt()
2055 {
2056 X error(0, "interrupted - to exit type (exit)", 0);
2057 }
2058 #endif UNIX
2059 */
2060 SHAR_EOF
2063 if test $? -ne 0
2065 fi
2067 then (
2069 ) << SHAR_EOF
2070 551c23b1de5cf69cfefa52c95af9330c apli/init.c
2071 SHAR_EOF
2072 else
2075 fi
2076 fi
2077 # ============= apli/io.c ==============
2080 else
2083 /* p44
2084 X * io.c */
2085 X
2086 #include "kernel.h"
2087 #include <math.h>
2088 #include <stdarg.h>
2089 X
2093 #define ESCAPE 033
2094 X
2095 #define LPARENTOK 1 /* ( */
2096 #define RPARENTOK 2 /* ) */
2097 #define LBRACKTOK 3 /* [ */
2098 #define RBRACKTOK 4 /* ] */
2099 #define LBRACETOK 5 /* { */
2100 #define RBRACETOK 6 /* } */
2102 #define BQUOTETOK 8 /* ` */
2103 #define COMMATOK 9 /* , */
2104 #define ATTOK 10 /* @ */
2105 #define HASHTOK 11 /* # */
2106 #define STRTOK 12 /* string token */
2107 #define SYMTOK 13 /* symbol token */
2108 #define EOLTOK 14 /* end-of-line token */
2109 #define EOFTOK 15 /* endmf-file token */
2110 #define INUMTOK 16 /* integer number token */
2111 #define RNUMTOK 17 /* real number token */
2112 X
2113 X
2114 #define NEXTtok(chan) ((chan)->tok = nexttok(chan))
2115 #define ISdigit(ch) ((ch) >= '0' && (ch) <= '9')
2116 #define DIGITvalue(ch) ((ch) - '0')
2117 X
2120 X
2126 X
2128 X
2130 X
2132 X iochan
2135 X int mode;
2136 {
2137 X
2138 X register iochan chan;
2139 X
2141 X
2143 X
2145 X
2147 X
2149 X
2151 X
2153 X
2155 X
2157 X
2158 X
2160 X iochan chan;
2161 {
2162 X
2165 X
2169 X
2171 X
2172 X
2174 {
2179 X
2181 X char
2183 X register iochan chan;
2184 {
2185 X
2186 X register char ch;
2187 X
2189 X
2190 X return (chan->ch = chan->buf [chan->pos++] );
2191 X
2192 X chan->pos = chan->len = 0;
2193 X
2194 X while ((ch = getc(chan->file) ) != EOL && ch != EOF)
2195 X
2196 X if (chan->len < CHANBUFSIZE) /* store it in the buffer */
2197 X
2198 X chan->buf[chan->len++] = ch;
2199 X
2200 X else {
2201 X
2202 X chan->buf [chan->len] = 0;
2203 X
2204 X while ((ch = getc(chan->file) ) != EOL && ch != EOF)
2205 X ; /* skip till end of line */
2206 X
2207 X error(readsym,"line too long", _mkstr(chan->buf));
2208 X }
2209 X
2210 X if (chan->len == 0) /* empty line? */
2211 X return (chan->ch = ch); /* ch is one of EOL, EOF */
2212 X chan->buf[ chan->len++] = EOL; /* put a newline at the end */
2213 X
2214 X chan->buf[chan->len] = 0; /* null the end of string */
2215 X
2216 X return (chan->ch = chan->buf[chan->pos++]);
2217 } /* nextch */
2218 X
2219 X
2220 /* 47 */
2221 nexttok (chan) /* fetch and return the next token fran chan */
2222 X register iochan chan;
2223 {
2224 start:
2225 X
2226 X while (chan->ch == SPACE || chan->ch == TAB) /* skip blanks */
2227 X
2228 X nextch (chan);
2229 X
2230 X switch (chan->ch) {
2231 X
2233 X
2235 X
2237 X
2239 X
2241 X
2243 X
2245 X
2247 X
2248 X case ',': nextch (chan); return (COMMATOK);
2249 X
2250 X case '@': nextch (chan); return (ATTOK);
2251 X
2252 X case '#': nextch (chan); return (HASHTOK);
2253 X
2254 X case ';': chan->pos = chan->len = 0; /* ignore comments */
2255 X nextch (chan);
2256 X goto start;
2257 X
2258 X case '"':
2259 X { register int i = 0; /* string is stored in strbuf */
2260 X
2261 X while (nextch(chan) != '"' &&
2262 X chan->ch != EOL && chan->ch != EOF)
2263 X
2265 X
2266 X strbuf [i] = 0;
2267 X
2268 X if (chan->ch == EOL || chan->ch == EOF)
2269 X error (readsym, "broken string", _mkstr(strbuf) );
2270 X
2271 X nextch(chan);
2272 X
2273 X return (STRTOK);
2274 X }
2275 X
2276 X case '|':
2277 X {
2278 X register int i = 0; /* strange atom is stored in strbuf */
2279 X
2280 X strbuf [i++] = chan->ch;
2281 X
2282 X while (nextch(chan) != '|' &&
2283 X chan->ch != EOL && chan->ch != EOF)
2284 X
2286 X
2287 X /* 48 */
2288 X strbuf [i++] = '|';
2289 X
2290 X strbuf [i] = 0;
2291 X
2292 X if (chan->ch == EOL || chan->ch == EOF)
2293 X error (readsym, "broken atom", _mkstr(strbuf ) );
2294 X nextch (chan);
2295 X
2296 X return(SYMTOK);
2297 X }
2298 X
2299 X case EOL: return (EOLTOK); /* end-of-line is reported */
2300 X case EOF: return (EOFTOK); /* end-of-file is reported */
2301 X case ESCAPE: nextch (chan); /* ignore escapes */
2302 X goto start;
2303 X
2304 X default:
2305 X {
2306 X register int i = 0; /* nums and syms are stored in strbuf */
2307 X
2308 X strbuf [i++] = chan->ch;
2309 X
2310 X while (nextch(chan) != '(' && chan->ch != ')'
2311 X && chan->ch != '[' && chan->ch != ']'
2312 X && chan->ch != '(' && chan->ch != '}'
2313 X && chan->ch != SPACE && chan->ch != TAB
2314 X && chan->ch != EOL && chan->ch != EOF)
2315 X
2316 X strbuf [i++] = chan->ch;
2317 X strbuf [i] = 0;
2318 X return (atomkind(strbuf));
2319 X }
2320 X } /* switch */
2321 } /* nexttok */
2322 X
2323 skipeoltok (chan, flag) /* skip eol token and return the next token */
2324 X register iochan chan;
2325 X int flag;
2326 {
2327 X if (flag)
2328 X NEXTtok(chan);
2329 X
2330 X while (chan->tok == EOLTOK) { /* skip eol's */
2331 X nextch(chan);
2332 X NEXTtok(chan);
2333 X }
2334 X return(chan->tok);
2335 } /* skipeoltok */
2336 X
2337 /* 49 */
2338 atomkind (name) /* work out whether nane is a number or symbol */
2339 X register char *name;
2340 {
2341 X
2342 X int sign = 1, frac = 0, places = 0;
2343 X double pow ();
2344 X
2345 X if (isnum(name)) {
2346 X
2347 X rnumber = inumber = 0;
2348 X
2349 X if (*name == '+' || *name == '-') /* signed rnumber? */
2350 X sign = (*name++ == '+' ? 1 : -1);
2351 X
2352 X while (*name && *name != '.') {
2353 X inumber = 10*inumber + DIGITvalue (*name);
2354 X ++name;
2355 X ++places;
2356 X }
2357 X
2358 X if (*name == '.') {
2359 X ++name;
2360 X
2361 X while (*name && ISdigit (*name) ) { /* work out fraction */
2362 X frac = 10*frac + DIGITvalue(*name);
2363 X ++name;
2364 X ++places;
2365 X }
2366 X rnumber = (float) (sign*(inumber+((double) frac) *
2367 X pow(10.0, - (double) places)));
2368 X return (RNUMTOK); /* real number */
2369 X }
2370 X inumber *= sign;
2371 X return (INUMTOK); /* integer number */
2372 X }
2373 X return (SYMTOK); /* symbol */
2374 } /* atomkind */
2375 X
2376 X
2377 isnum (name) /* is name a number string? */
2378 X register char *name;
2379 {
2380 X int decpoint = 0;
2381 X
2382 X if (*name == '+' || *name == '-' )
2383 X
2384 X /* ~y name can'0 be number */
2385 X if (*name == 0)
2386 X return (0);
2387 X
2388 X while (*name && (ISdigit (*name) || *name == '.')) {
2389 X
2390 X if (*name == '.') { /* at most 1 decjmal point allowed */
2391 X
2392 X if (decpoint)
2393 X return (0);
2394 X
2395 X decpoint = 1;
2396 X }
2397 X ++name; /* skip all digjts and deciHHLL point */
2398 X }
2399 X return (*name == 0); /* there most be nothing left */
2400 X
2401 } /* isnum */
2402 X
2403 X
2404 X
2405 X
2406 /* 051
2407 X 42 lnternal I/O functfons
2408 X */
2409 X
2410 X kerncell
2411 readaux(chan,bq) /* read an suppression fran chan */
2412 X iochan chan;
2413 X int bq; /* non-zero when in a back~uoted s-expression */
2414 {
2415 X int save_celltop = celltop; /* save top of cell stack */
2416 X kerncell obj;
2417 X
2418 X if (chan == _inchan && _outchan->len > 0) {
2419 X fprintf (_outchan->file,"%s", _outchan->buf); /* flush output */
2420 X _outchan->len = 0;
2421 X }
2422 X
2423 X obj = readaux1 (chan,bq);
2424 X celltop = save_celltop; /* restore top of cell stack */
2425 X return (CELLpush(obj));
2426 } /* readaux */
2427 X
2428 X
2429 X kerncell
2430 readaux1 (chan, bq) /* read an s-expression: for internal use ONLY */
2431 X register iochan chan;
2432 X int bq; /* non-zero when in a backquoted s~ression */
2433 {
2434 X kerncell obj;
2435 X
2436 start:
2437 X
2438 X skipeoltok (chan, 0);
2439 X
2440 X switch (chan->tok) {
2441 X
2442 X case SYMTOK:
2443 X obj = CONVcell (mksym(strbuf) );
2444 X NEXTtok (chan);
2445 X break;
2446 X
2447 X case INUMTOK:
2448 X obj = mkinum(inumber);
2449 X NEXTtok (chan);
2450 X break;
2451 X
2452 X case RNUMTOK:
2453 X obj = mkrnum(rnumber);
2454 X NEXTtok (chan);
2455 X break;
2456 X
2457 X case STRTOK:
2458 X obj = mkstr(strbuf);
2459 X NEXTtok (chan);
2460 X break;
2461 X
2462 X case LPARENTOK:
2463 X case LBRACKTOK:
2464 X { /* NOTE: ) matches ( only, and ] matches [ only */
2465 X int right = (chan->tok == LPARENTOK ? RPARENTOK : RBRACKTOK);
2466 X register kerncell list;
2467 X
2468 X if (skipeoltok (chan, 1) == right) {
2469 X NEXTtok (chan);
2470 X return (NIL);
2471 X } /* () */
2472 X
2473 X /* 52 */
2474 X obj = list = mkcell (readaux1(chan,bq), nil); /* (* ... ) */
2475 X
2476 X while (skipeoltok(chan, 0),
2477 X chan->tok != RPARENTOK && chan->tok != RBRACKTOK
2478 X && chan->tok != EOFTOK) {
2479 X
2480 X list->CELLcdr = mkcell (readaux1 (chan,bq), nil);
2481 X
2482 X list = list->CELLcdr;
2483 X }
2484 X if (chan->tok == EOFTOK)
2485 X error (readsym, "unexpected end of file", 0);
2486 X
2487 X if (chan->tok != right) {
2488 X if (chan->tok == RPARENTOK)
2489 X error(readsym,"[ ... ) is not allowed",0);
2490 X else
2491 X error(readsym,"( ... ] is not allowed",0);
2492 X }
2493 X NEXTtok(chan);
2494 X break;
2495 X }
2496 X
2497 X case LBRACETOK:
2498 X { register kerncell set;
2499 X
2500 X if (skipeoltok (chan, 1) == RBRACETOK) {
2501 X NEXTtok (chan);
2502 X return (NIL); /* {} */
2503 X }
2504 X obj = set = mkset(readaux1(chan,bq),nil); /* (* ... ) */
2505 X while (skipeoltok (chan, 0),
2506 X chan->tok != RBRACETOK && chan->tok != EOFTOK) {
2507 X set->CELLcdr = mkset (readaux1 (chan, bq), nil);
2508 X set = set->CELLcdr;
2509 X }
2510 X
2511 X if (chan->tok == EOFTOK)
2512 X error (readsym, "unexpected end of file",0);
2513 X obj = remrep(obj);
2514 X NEXTtok (chan);
2515 X break;
2516 X }
2517 X
2518 X case QUOTETOK:
2519 X NEXTtok (chan);
2520 X obj = mkcell (quotesym,mkcell (readaux1 (chan,bq), nil) );
2521 X break;
2522 X
2523 X case BQUOTETOK:
2524 X NEXTtok (chan);
2525 X obj = transform(readaux1 (chan, 1) );
2526 X break;
2527 X
2528 X case COMMATOK:
2529 X NEXTtok(chan);
2530 X if (!bq)
2531 X error (readsym, " ', ' outside a back~ted smxpresion", 0);
2532 X obj = mkcell (_commasym, readaux1 (chan,bq) );
2533 X break;
2534 X
2535 X case ATTOK:
2536 X NEXTtok (chan);
2537 X /* 53 */
2538 X if (! bq)
2539 X error (readsym, " '9 ' outside a backdated pression",0);
2540 X obj = mkcell(_atsym, readaux1(chan,bq));
2541 X break;
2542 X
2543 X case HASHTOK:
2544 X NEXTtok(chan);
2545 X obj = eval(readaux1 (chan,bq) );
2546 X break;
2547 X
2548 X case EOLTOK:
2549 X chan->ch = SPACE;
2550 X NEXTtok (chan);
2551 X goto start;
2552 X
2553 X case EOFTOK:
2554 X return (CONVcell (eofsym) );
2555 X
2556 X case RPARENTOK:
2557 X NEXTtok (chan);
2558 X error (readsym, "unexpected ')'", 0);
2559 X
2560 X case RBRACKTOK:
2561 X NEXTtok (chan);
2562 X error (readsym, "unexpected ']'", 0);
2563 X
2564 X case RBRACETOK:
2565 X NEXTtok (chan);
2566 X error (readsym, "unexpected '}'", 0);
2567 X
2568 X default:
2569 X NEXTtok (chan);
2570 X return (NIL);
2571 X
2572 X } /* switch */
2573 X return (obj);
2574 } /* readaux1 */
2575 X
2576 X
2577 hasmacro (expr) /* returns non-zero when expr contains ',' or '@' */
2578 X register kerncell expr;
2579 {
2580 X if (! ISlist (expr) )
2581 X return (0);
2582 X if (expr->CELLcar == CONVcell(_commasym) ||
2583 X expr->CELLcar == CONVcell(_atsym))
2584 X return (1);
2585 X
2586 X while (ISlist (expr) ) {
2587 X if (hasmacro (expr->CELLcar) )
2588 X return (1);
2589 X expr = expr->CELLcdr;
2590 X }
2591 X return (0);
2592 } /* hasmacro */
2593 X
2594 X
2595 /* 54 */
2596 kerncell
2597 transform (list) /* transform back-quoted s-expressions */
2598 X kerncell list;
2599 {
2600 X
2601 X kerncell obj;
2602 X
2603 X if (list == NIL)
2604 X return (NIL);
2605 X
2606 X if (! hasmacro(list) )
2607 X return (mkcell(quotesym,mkcell (list, nil) ) );
2608 X
2609 X if (! ISlist(obj = list->CELLcar) ) {
2610 X if (obj == CONVcell(_commasym) || obj == CONVcell(_atsym) )
2611 X return (eval(transform(list->CELLcdr) ) );
2612 X
2613 X return (mkcell(conssym,
2614 X mkcell(mkcell (quotesym,mkcell (obj, nil) ),
2615 X mkcell (transform(list->CELLcdr, nil)))));
2616 X }
2617 X if (obj->CELLcar == CONVcell(_commasym))
2618 X return (mkcell(conssym,
2619 X mkcell(eval(transform(obj->CELLcdr)),
2620 X mkcell (transform(list->CELLcdr), nil) ) ) );
2621 X
2622 X if (obj->CELLcar == CONVcell(_atsym))
2623 X return (mkcell(concsym,
2624 X mkcell(eval(transform(obj->CELLcdr) ),
2625 X mkcell (transform(list->CELLcdr), nil))));
2626 X
2627 X return (mkcell (conssym,
2628 X mkcell (transform(obj),
2629 X mkcell(transform(list->CELLcdr), nil))));
2630 } /* transform */
2631 X
2632 /* 55 */
2633 printaux (flag, expr, chan, max) /* auxiliary */
2634 X int flag;
2635 X register kerncell expr;
2636 X iochan chan;
2637 X int max; /* max specifies an upper bound when flag is LENGTH */
2638 {
2641 X if (ISsym(expr)) /* is expr a symbol? */
2642 X {
2644 X return(bufprint((flag == PRINC && *CONVsym(expr)->name == '|'
2645 X ? STRIP: flag),
2646 X chan, "%s", CONVsym(expr)->name));
2647 X }
2648 X /* 56
2649 X Input and Output
2650 X */
2651 X
2653 X switch (expr->flag) {
2654 X
2655 X case INTOBJ: {
2657 X return (bufprint (flag, chan, "%ld", expr->CELLinum) );
2658 X }
2659 X case REALOBJ:
2660 X {
2662 X return (bufprint (flag, chan, "%f", expr->CELLrnum) );
2663 X }
2664 X case STROBJ:
2665 X {
2667 X return (bufprint (flag, chan,
2669 X expr->CELLstr) );
2670 X }
2671 X case CHANOBJ:
2672 X {
2674 X return (bufprint (flag, chan, "<channel:%1d>", expr->CELLchan));
2675 X }
2676 X
2677 X case VECTOROBJ:
2678 X {
2680 X return (bufprint (flag, chan, "vector [Old] ",
2681 X expr->CELLdim->CELLinum));
2682 X }
2683 X case LISTOBJ:
2684 X {
2686 X if (expr->CELLcar == CONVcell (quotesym)) {
2687 X bufprint (flag, chan, " ' ");
2688 X return(1 + printaux(flag, expr->CELLcdr->CELLcar, chan, max));
2689 X }
2690 X }
2691 X case SETOBJ: /* handles lists and sets */
2692 X { int size;
2693 X int oflag = expr->flag;
2694 X
2696 X size = bufprint(flag, chan,(oflag == LISTOBJ ? "(" : "{"));
2697 X if (flag == LENGTH && size > max)
2698 X return(size);
2699 X do {
2700 X size += printaux(flag,expr->CELLcar,chan,max);
2701 X if ((expr = expr->CELLcdr) != NIL) {
2702 X if (expr->flag != oflag) {
2703 X if (flag == LENGTH && size > max)
2704 X return(size);
2705 X
2706 X size += bufprint(flag, chan, " . ");
2707 X size += printaux(flag,expr,chan,max);
2708 X break;
2709 X }
2710 X else
2711 X size += bufprint (flag, chan, " ");
2712 X }
2713 X } while (expr != NIL);
2714 X
2715 X size += bufprint(flag, chan, (oflag == LISTOBJ ? ")" : "}"));
2716 X return (size);
2717 X }
2718 X default:
2719 X return(bufprint( flag, chan, "<@:%1d>", expr->CELLcar));
2720 X
2721 X } /* switch */
2722 X
2723 } /* printauc */
2724 X
2725 X
2726 /* 57 */
2727 X
2728 extern int count_percent( char *);
2729 X
2730 bufprint (int flag, iochan chan, char *format, ...) /* buffered print */
2731 X /*
2732 X int flag;
2733 X iochan chan;
2734 X char *format;
2735 X */
2736 {
2737 X static char outputbuf [CHANBUFSIZE+2];
2738 X char *outbuf = outputbuf;
2739 X va_list args;
2740 X va_start( args, format); /* variable length argument */
2741 X // int len;
2742 X // len = count_percent( format );
2743 X vsprintf (outbuf, format, args);
2744 X va_end(args);
2745 X
2746 X if (flag == LENGTH)
2747 X return (strlen (outputbuf ) );
2748 X else if (flag == STRIP) { /* strip (symbol) to symbol */
2749 X ++outbuf;
2750 X *(outbuf + strlen(outbuf) - 1) = 0;
2751 X }
2752 X
2753 X if (chan->len > 0)
2754 X --(chan->len); /* get rid of the last null char */
2755 X
2756 X do {
2757 X *(chan->buf + chan->len++) = *outbuf;
2758 X
2759 X if (*outbuf == EOL || chan->len > CHANBUFSIZE) {
2760 X *(chan->buf + chan->len) = 0;
2761 X fprintf (chan->file, "%s" , chan->buf );
2762 X chan->len = 0;
2763 X
2764 X if (!*(outbuf + 1))
2765 X break;
2766 X }
2767 X
2768 X } while (*outbuf++);
2769 X
2770 X return (strlen(outputbuf));
2771 } /* bufprint */
2772 X
2773 /* 58 */
2774 X kerncell
2775 Lopen () /* (open 'name 'mode) */
2776 {
2777 X
2778 X kerncell arg1 = ARGnum1;
2779 X kerncell arg2 = ARGnum2;
2780 X
2781 X CHECKlargs(opensym, 2);
2782 X return (openaux(
2783 X GETstr(opensym, arg1),
2784 X GETstr(opensym, arg2)));
2785 X
2786 } /* Lopen */
2787 X
2788 X
2789 X kerncell
2790 openaux (name,mode) /* open a channel */
2791 X char *name, *mode;
2792 {
2793 X
2794 X FILE *file, *fopen();
2795 X
2796 X if ((file = fopen(name, mode) ) == NULL)
2797 X error (opensym, "can't open file", mkstr (name) );
2798 X return (mkchan (openchan (file,
2799 X (*mode == 'r'
2800 X ? (*++mode != 0 ? INOUTCHAN: INCHAN)
2801 X : OUTCHAN))));
2802 X
2803 } /* openaux */
2804 X
2805 X kerncell
2806 Lclose () /* (close 'chan) */
2807 {
2808 X kerncell arg = ARGnum1;
2809 X
2810 X CHECKlargs ( closesym, 1);
2811 X
2812 X closechan (GETchan(closesym, arg) );
2813 X
2814 X arg->flag = VOID; /* arg is no more a channel */
2815 X
2816 X return (TTT);
2817 X
2818 } /* Lclose */
2819 X
2820 /* 59 */
2821 X kerncell
2822 Vflush () /* (flush ['chan]) */
2823 {
2824 X kerncell arg;
2825 X iochan chan;
2826 X
2827 X CHECKvargs2 (flushsym, 1);
2828 X
2829 X chan = (ARGidx1 == argtop
2830 X ? _outchan
2831 X : (arg = ARGnum1, GETchan(flushsym,arg) ) );
2832 X
2833 X if (chan->len == 0)
2834 X return (TTT);
2835 X
2836 X if (chan->mode == OUTCHAN || chan->mode == INOUTCHAN)
2838 X
2839 X else
2840 X chan->len = 0;
2841 X return(TTT);
2842 } /* Vflush */
2843 X
2844 X kerncell
2845 Vread ()
2846 {
2847 X
2848 X /* (read ['chan]) */
2849 X
2850 X kerncell arg;
2851 X
2852 X CHECKvargs2 (readsym, 1);
2853 X
2854 X if (argtop == ARGidx1)
2855 X return (readaux (_inchan,0) ) ;
2856 X
2857 X else {
2858 X
2859 X if ( !ISchan( arg= ARGnum1) || arg->CELLchan->mode == OUTCHAN)
2860 X error(readsym, err_chan2, arg);
2861 X
2862 X return (readaux ( arg->CELLchan, 0));
2863 X }
2864 } /* Vread */
2865 X
2866 /* 60 */
2867 X kerncell
2868 Vprint () /* (print 'expr ['chan]) */
2869 {
2870 X kerncell arg2;
2871 X
2872 X CHECKvargs(printsym, 1, 2);
2873 X
2874 X if (argtop - ARGidx1 == 1)
2875 X printaux (PRINT, ARGnum1, outchan, 2);
2876 X
2877 X else {
2878 X if (! ISchan(arg2 = ARGnum2) || arg2->CELLchan->mode == INCHAN)
2879 X error (printsym, err_chan2, arg2);
2880 X
2881 X printaux(PRINC, ARGnum1, arg2->CELLchan, 2);
2882 X }
2883 X return (TTT);
2884 X
2885 } /* Vprint */
2886 X
2887 X kerncell
2888 Vprinc () /* (princ 'expr ['chan]) */
2889 {
2890 X kerncell arg2;
2891 X
2892 X if (argtop - ARGidx1 == 1)
2893 X printaux (PRINC, ARGnum1, outchan, 2);
2894 X
2895 X else {
2896 X if (! ISchan(arg2 = ARGnum2) || arg2->CELLchan->mode == INCHAN)
2897 X error (princsym, err_chan2, arg2);
2898 X printaux(PRINC, ARGnum1, arg2->CELLchan, 2);
2899 X }
2900 X return (TTT);
2901 } /* Vprinc */
2902 X
2903 /* 61 */
2904 X kerncell
2905 Vtab () /* (tab 'column f'chan]) */
2906 {
2907 X kerncell arg1 = ARGnum1, arg2;
2908 X iochan chan;
2909 X
2910 X CHECKvargs (tabsym, 1, 2);
2911 X
2912 X if (argtop - ARGidx1 == 1)
2913 X chan = _outchan;
2914 X
2915 X else {
2916 X if (! ISchan (arg2 = ARGnum2) || arg2->CELLchan->mode == INCHAN)
2917 X error (tabsym, err_chan2, arg2);
2918 X chan = arg2->CELLchan;
2919 X }
2920 X
2921 X arg1 = ARGnum1;
2922 X
2923 X tab (GETint (tabsym, arg1), chan);
2924 X
2925 X return (TTT);
2926 } /* Vtab */
2927 X
2928 X
2929 tab (column, chan) /* tab */
2930 X int column;
2931 X iochan chan;
2932 {
2933 X if (column > CHANBUFSIZE)
2934 X column = CHANBUFSIZE;
2935 X
2936 X if (chan->len > column)
2938 X
2939 X if (column < 0)
2940 X return;
2941 X
2942 X while (chan->len < column)
2943 X *(chan->buf + chan->len++) = SPACE ;
2944 X *(chan->buf + chan->len) = 0;
2945 X
2946 } /* tab */
2947 X
2948 X kerncell
2949 Vterpri () /* (terpri ['chan]} */
2950 {
2951 X
2952 X kerncell arg;
2953 X
2954 X CHECKvargs2 (terprisym, 1);
2955 X
2956 X if (argtop == ARGidx1)
2958 X
2959 X if ( !ISchan(arg = ARGnum1) || arg->CELLchan->mode == INCHAN)
2960 X error (terprisym, err_chan2, arg);
2961 X
2963 X
2964 X return (TTT);
2965 X
2966 } /* Vterpri */
2967 X
2968 /* 62 */
2969 X kerncell
2970 Vprlen () /* (prlen 'expr ['max] } */
2971 {
2972 X kerncell arg2;
2973 X int max;
2974 X
2975 X CHECKvargs (prlensym, 1, 2);
2976 X
2977 X max = (argtop - ARGidx1 == 1
2978 X ? MAXCOLS
2979 X : (arg2 = ARGnum2, GETint (prlensym,arg2) ) );
2980 X
2981 X return (mkinum(printaux (LENGTH, ARGnum1, outchan,max) ) ) ;
2982 } /* vprlen */
2983 X
2984 X kerncell
2985 Viobuf () /* (iobuf ['chan]) */
2986 {
2987 X
2988 X kerncell arg;
2989 X
2990 X CHECKvargs2 (iobufsym,1 );
2991 X return (mkinum(ARGidx1 == argtop
2992 X ?_outchan->len
2993 X :(arg = ARGnum1, GETchan (iobufsym, arg)->len) ) );
2994 X
2995 } /* Viobuf */
2996 X
2997 X kerncell
2998 Lchanp() /* (chan? 'expr) */
2999 {
3000 X CHECKlargs (chanpsym, 1);
3001 X return(ISchan(ARGnum1) ? TTT : NIL) ;
3002 X
3003 } /* Lchanp */
3004 X
3005 /* 63 */
3006 X kerncell
3007 Vpp() /* (pp 'expr ['chan]) */
3008 {
3009 X kerncell arg1 = ARGnum1;
3010 X kerncell arg2;
3011 X
3012 X CHECKvargs (ppsym, 1, 2);
3013 X ppgap = MAXCOLS;
3014 X
3015 X pp ( (ISfun(arg1) ? CONVsym(arg1)->bind : arg1),
3016 X (argtop - ARGidx1 == 1
3017 X ? outchan
3018 X : (!ISchan (arg2 = ARGnum2) || arg2->CELLchan->mode == INCHAN
3019 X ? CONVchan (error (ppsym,err_chan2, arg2) )
3020 X : arg2->CELLchan) ),
3021 X 0,0);
3022 X return (TTT);
3023 X
3024 } /* Vpp */
3025 X
3026 /* 64 */
3027 X
3028 pp (expr, chan, lmar, rmar) /* pretty print expr within the margins */
3029 X register kerncell expr;
3030 X iochan chan;
3031 X int lmar, rmar;
3032 {
3033 X int flag = expr->flag;
3034 X int lmarl;
3035 X
3036 X if (lmar > llimit && printaux(LENGTH,expr,chan,rlimit) > rlimit) {
3038 X pp(expr, chan, 4, 0);
3040 X return;
3041 X }
3042 X tab (lmar, chan);
3043 X
3044 X if (! ISlist (expr) ) {
3045 X printaux (PRINT, expr, chan, 2);
3046 X
3047 X return;
3048 X }
3049 X bufprint(PRINT, chan, (flag == LISTOBJ ? "(" : "{"));
3050 X if (printlen(expr, chan, rmar) < ppgap)
3051 X
3052 X do {
3053 X pp (expr->CELLcar, chan, chan->len, rmar);
3054 X
3055 X if ((expr = expr->CELLcdr) != NIL)
3056 X if (expr->flag != flag) {
3057 X bufprint(PRINT,chan," . "); /* dotted pair */
3058 X pp(expr, chan, chan->len, rmar);
3059 X break;
3060 X }
3061 X else
3062 X
3063 X bufprint(PRINT, chan, " ") ;
3064 X
3065 X } while (expr != NIL);
3066 X else {
3067 X
3068 X if (! ISlist(expr->CELLcar) && ISlist(expr->CELLcdr->CELLcdr)) {;
3069 X
3070 X pp(expr->CELLcar, chan, chan->len, rmar);
3071 X bufprint(PRINT, chan, " ") ;
3072 X expr = expr->CELLcdr;
3073 X }
3074 X
3075 X /* 65
3076 X 43 Kernel Ilo funcaons
3077 X */
3078 X
3079 X lmarl = chan->len; /* freeze left margin */
3080 X
3081 X do {
3082 X pp (expr->CELLcar, chan, lmarl,
3083 X (expr->CELLcdr == NIL ? rmar + 1: rmar) );
3084 X
3085 X if ( (expr = expr->CELLcdr) != NIL) {
3086 X if (expr->flag != flag) {
3087 X bufprint (PRINT, chan," . "); /* dotted pair */
3088 X pp(expr, chan, lmarl, rmar);
3089 X break;
3090 X }
3091 X else
3092 X bufprint (PRINT, chan, " ");
3093 X }
3094 X } while (expr != NIL);
3095 X }
3096 X bufprint (PRINT, chan, (flag = LISTOBJ ? ") ": "}") );
3097 X
3098 } /* pp */
3099 X
3100 printlen (expr, chan, rmar) /* length of expr */
3101 X kerncell expr;
3102 X iochan chan;
3103 X int rmar;
3104 {
3105 X
3106 X int len;
3107 X ppgap = ppcols - chan->len;
3108 X
3109 X len = printaux (LENGTH, expr, chan, ppgap);
3110 X
3111 X return(rmar + (len > ppgap ? ppgap: len) );
3112 } /* printlen */
3113 X
3114 SHAR_EOF
3116 chmod 0644 'apli/io.c'
3117 if test $? -ne 0
3119 fi
3121 then (
3123 ) << SHAR_EOF
3124 e1e79ca2a98ec93aa61bc5908b847aac apli/io.c
3125 SHAR_EOF
3126 else
3129 fi
3130 fi
3131 # ============= apli/iter.c ==============
3134 else
3136 sed 's/^X//' << 'SHAR_EOF' > 'apli/iter.c' &&
3137 /* 126 Nonstandard Flo~ of Control and Iteration */
3138 /* iter.c */
3139 X
3140 #include "kernel.h"
3141 X
3142 X kerncell
3143 Uprog () /* (prog (. ~ .vars...) ...gody...) */
3144 {
3145 X kerncell list = argstk[argtop];
3146 X register kerncell vars, save;
3147 X kerncell fox;
3148 X register kernsym sym;
3149 X
3150 X /* 127 9.2 Explicit iteration functions */
3151 X
3152 X if (list == NIL || (!ISlist (vars = list->CELLcar) && vars != NIL))
3153 X error (progsym, "bad variable list" ,vars);
3154 X
3155 X save = vars; /* save a pointer to vars */
3156 X
3157 X while (ISlist (vars) ) { /* Process variable */
3158 X
3159 X if (ISsym(fox = vars->CELLcar) && !ISconst(CONVsym(fox))) {
3160 X
3161 X VARpush (sym = CONVsym(fox) , sym->flag, sym->bind);
3162 X
3163 X sym->flag = VARIABLE;
3164 X
3165 X sym->bind = NIL; /* in which case it is bound to nil */
3166 X }
3167 X
3168 X else if (ISlist(fox)) { /* or a llst: (var init) */
3169 X
3170 X /* some bugs to fix, since w/o the brace, compile error apppears */
3171 X if (ISsym(sym = CONVsym(fox->CELLcar)) && !ISconst(sym)) { /* this brace for prevent
3172 X compiler error */
3173 X VARpush (sym, sym->flag, sym->bind);
3174 X }
3175 X else
3176 X error (progsym, err_var, sym);
3177 X sym->flag = VARIABLE; /* in which case lt is bound to init */
3178 X sym->bind = eval (fox->CELLcdr->CELLcar);
3179 X }
3180 X else
3181 X error (progsym, err_var, fox);
3182 X
3183 X vars = vars->CELLcdr;
3184 X }
3185 X fox = catch (prog, _rettagsym, list->CELLcdr) ; /* take care of returns */
3186 X while (ISlist (save) ) { /* restore varlable bindings, etc. */
3187 X
3188 X VARpop();
3189 X save = save->CELLcdr;
3190 X }
3191 X return (fox);
3192 }/* Uprog */
3193 X
3194 X kerncell
3195 prog (list) /* list lS the body of the prog */
3196 X register kerncell list;
3197 {
3198 X kerncell save = list;
3199 X
3200 start:
3201 X /* catch go's: */
3202 X
3203 X if (catch (progaux,_gotagsym, list) == CONVcell( _gotagsym)) {
3204 X
3205 X for (list=save; ISlist (list) ; list=list->CELLcdr)
3206 X if (list->CELLcar == golabel) {
3207 X
3208 X list = list->CELLcdr;
3209 X goto start;
3210 X }
3211 X error (gosym, "no such label", golabel);
3212 X }
3213 X else
3214 X
3215 X return (NIL);
3216 X
3217 } /* prog */
3218 X
3219 /* 128 */
3220 X kerncell
3221 progaux (list) /* auxilliary */
3222 X register kerncell list;
3223 {
3224 X while (ISlist (list)) { /* evaluate each list, but */
3225 X if (ISlist (list->CELLcar) )
3226 X eval (list->CELLcar);
3227 X
3228 X list = list->CELLcdr;
3229 X }
3230 X return (NIL);
3231 }/* progaux */
3232 X
3233 X kerncell
3234 Ugo() /* (G0 label) */
3235 {
3236 X if (!ISlist (argstk [argtop ] ))
3237 X error (gosym, "label required", 0);
3238 X
3239 X golabel = argstk [argtop] ->CELLcar;
3240 X
3241 X throw(_gotagsym,_gotagsym);
3242 X
3243 }/*Uq0*/
3244 X
3245 X kerncell
3246 Vreturn () /* (return ['result]) */
3247 {
3248 X CHECKvargs2 (returnsym, 1);
3249 X
3250 X throw((ARGidx1 == argtop ? NIL : ARGnum1), _rettagsym);
3251 X
3252 } /* vreturn */
3253 X
3254 X
3255 /* 129 9.3 Implicit iteration functions */
3256 X
3257 X kerncell
3258 Udo () /* (do n exprl exprn) */
3259 {
3260 X
3261 X kerncell list = argstk[argtop];
3262 X kerncell res = NIL;
3263 X register kerncell fox;
3264 X register int times;
3265 X
3266 X if (list->CELLcdr == NIL)
3267 X error (dosym, err_args, 0);
3268 X
3269 X fox = eval (list->CELLcar);
3270 X
3271 X times = GETint (dosym, fox);
3272 X
3273 X list = list->CELLcdr;
3274 X
3275 X while (times-- > 0) {
3276 X
3277 X fox = list;
3278 X
3279 X while (ISlist (fox) ) {
3280 X
3281 X res = eval (fox->CELLcar);
3282 X
3283 X fox = fox->CELLcdr;
3284 X }
3285 X }
3286 X return (res);
3287 }/* Udo */
3288 X
3289 SHAR_EOF
3291 chmod 0644 'apli/iter.c'
3292 if test $? -ne 0
3294 fi
3296 then (
3298 ) << SHAR_EOF
3299 bbef4e3e8fbdacdc809a9e293acdb45c apli/iter.c
3300 SHAR_EOF
3301 else
3304 fi
3305 fi
3306 # ============= apli/kcomp.c ==============
3309 else
3311 sed 's/^X//' << 'SHAR_EOF' > 'apli/kcomp.c' &&
3312 /* 148 kcomp.c */
3313 X
3314 #include "kernel.h"
3315 #include "stdlib.h"
3316 X
3317 typedef struct snode { /* symbol/string node */
3318 X
3319 X char *str; /* string/symbol name */
3320 X kernsym sym; /* denoting variable */
3321 X struct snode *left, *right; /* child nodes */
3322 X
3323 } *stree;
3324 X
3325 typedef struct inode { /* integer node */
3326 X
3327 X int inum; /* integer value */
3328 X kernsym sym; /* denoting variable */
3329 X struct inode *left, *right; /* child nodes */
3330 X
3331 } *itree;
3332 X
3333 typedef struct rnode { /* real node */
3334 X
3335 X real rnum; /* real value */
3336 X kernsym sym; /* denoting Variable */
3337 X struct rnode *left, *right; /* child nodes */
3338 X
3339 } *rtree;
3340 X
3341 stree symtree = NULL; /* symbol tree */
3342 stree strtree = NULL; /* string tree */
3343 itree inumtree = NULL; /* integer tree */
3344 rtree rnumtree = NULL; /* real tree */
3345 kernsym lastsym; /* last symbol */
3346 X
3347 char *source, *target; /* source and target file names */
3348 X
3349 main (argn, argv) /* main */
3350 X int argn;
3351 X char *argv[];
3352 {
3353 X
3354 X int len;
3355 X // char *malloc();
3356 X
3357 X kerncell compile();
3358 X
3359 X /* 149 */
3360 X if (argn <= 1) {
3362 X exit (1);
3363 X }
3364 X
3365 X if ((len = strlen(source = argv[1])) < 3 || /* check source */
3366 X source[len-2] != '.' || source[len-1] != 'k') {
3367 X
3369 X
3370 X exit (1);
3371 X }
3372 X
3373 X if (argn >= 3) {
3374 X
3375 X if ((len = strlen (target = argv[2])) < 3 || /* check target */
3376 X target [len-2] != '.' || target[len-1] != 'c') {
3377 X
3379 X
3380 X exit (1);
3381 X }
3382 X }
3383 X /* default tarqet */
3384 X
3385 X else {
3386 X
3387 X target = malloc (len + 1);
3388 X
3389 X strcpy (target, source);
3390 X
3391 X target [len-1] = 'c';
3392 X
3393 X target [len] = 0;
3394 X
3395 X initialize ();
3396 X }
3397 X if (catch(compile, _toptagsym, 1) == NIL) {
3398 X
3400 X
3401 X exit (1);
3402 X }
3403 X exit(0);
3404 X
3405 }/* main */
3406 X
3407 X kerncell
3408 compile () /* compile */
3409 {
3410 X
3411 X kerncell compaux ();
3412 X
3413 X return (caperr(compaux,NIL, 1) );
3414 X
3415 } /* compile */
3416 X
3417 /* 150 */
3418 X
3419 X kerncell
3420 compaux() /* auxiliary */
3421 {
3422 X kerncell schan, tchan;
3423 X register kerncell form, forms = NIL;
3424 X kerncell procform();
3425 X
3426 X schan = openaux (source, "r"); /* open source file */
3427 X
3428 X tchan = openaux (target, "w"); /* open target file .*/
3429 X
3430 X while (eval (readaux(schan->CELLchan, 0)) != CONVcell (eofsym));
3431 X
3432 X closechan (schan->CELLchan); /* close source file */
3433 X
3434 X schan = openaux (source, "r"); /* re-open source file */
3435 X
3436 X while ((form = readaux(schan->CELLchan, 0)) != CONVcell(eofsym));
3437 X
3438 X forms = mkcell(procform(form, 1) ,forms);
3439 X
3440 X closechan (schan->CELLchan); /* close source file */
3441 X
3442 X forms = dreverse (forms);
3443 X
3444 X bufprint (PRINC, tchan->CELLchan, /* produce object code: */
3446 X
3448 X
3449 X gensyms (symtree, tchan->CELLchan); /* generate symbols */
3450 X
3451 X genstrs (strtree, tchan->CELLchan); /* generate strings */
3452 X
3453 X geninums (inumtree, tchan->CELLchan); /* generate :Lntegers */
3454 X
3455 X genrnums (rnumtree,tchan->CELLchan); /* generate reals */
3456 X
3457 X gencode (forms , tchan->CELLchan); /* qenerate code for the forms */
3458 X
3460 X
3461 X bufprint (PRINC, tchan->CELLchan, /* main functlon */
3463 X
3464 X closechan (tchan->CELLchan);
3465 X
3466 X return (NIL);
3467 } /* compaux */
3468 X
3469 /* 151 */
3470 X
3471 X kerncell
3472 procform (form, expd) /* process a fonn */
3473 X register kerncell form;
3474 X int expd;
3475 {
3476 X kerncell convert (), head;
3477 X stree addstr ();
3478 X itree addinum();
3479 X rtree addrnum();
3480 X
3481 X if (ISsym(form)) {
3482 X symtree = addstr (symtree, CONVsym( form) ->name);
3483 X return (CONVcell (lastsym) );
3484 X }
3485 X
3486 X if (ISstr (form) ) {
3487 X strtree = addstr (strtree, form->CELLstr);
3488 X return (CONVcell (lastsym) );
3489 X }
3490 X if (ISint (form)) {
3491 X inumtree = addinum(inumtree, form->CELLinum);
3492 X return (CONVcell (lastsym) );
3493 X }
3494 X if (ISreal (form) ) {
3495 X rnumtree = addrnum(rnumtree, form->CELLrnum);
3496 X return (CONVcell (lastsym) );
3497 X }
3498 X
3499 X if ((form->CELLcar) == CONVcell(quotesym) )
3500 X return (convert (form, 0) );
3501 X
3502 X if (expd &&
3503 X ((ISfun(form->CELLcar) &&
3504 X ((head = CONVsym(form->CELLcar)->bind)->CELLcar)
3505 X == CONVcell(mlamsym)) ||
3506 X (ISlist(head = form->CELLcar) &&
3507 X (head->CELLcar == CONVcell(mlamsym)))))
3508 X procform (expand (head, form, 0) , expd);
3509 X
3510 X return (convert (form, expd) );
3511 } /* procform */
3512 X
3513 /* 152 */
3514 X
3515 X kerncell
3516 convert (form, expd) /* convert a form */
3517 X kerncell form;
3518 X int expd;
3519 {
3520 X if (form = NIL)
3521 X return (NIL);
3522 X
3523 X return (mkcell (procform (form->CELLcar, expd),
3524 X convert (form->CELLcdr, expd) ) );
3525 } /* convert */
3526 X
3527 X stree
3528 addstr (tree, str) /* add string/ symbol to string/ symbol tree */
3529 X stree tree;
3530 X char *str;
3531 {
3532 X kernsym gensym();
3533 X // char *malloc();
3534 X int cmp;
3535 X
3536 X if (tree == NULL) {
3537 X
3538 X if ((tree = (struct snode *)malloc(sizeof (struct snode))) == NULL){
3540 X exit(1);
3541 X }
3542 X tree->str = str;
3543 X tree->sym = lastsym = gensym();
3544 X tree->left = tree->right = NULL;
3545 X }
3546 X else if ((cmp - strcmp(str,tree->str)) < 0)
3547 X tree->left = addstr (tree->left, str);
3548 X
3549 X else if(cmp>0)
3550 X tree->right = addstr (tree->right, str);
3551 X
3552 X else
3553 X lastsym = tree->sym;
3554 X
3555 X return (tree);
3556 }/*addstr*/
3557 X
3558 /* 153 */
3559 X
3560 X itree
3561 addinum (tree, inum) /* add integer to integer tree */
3562 X
3563 X itree tree;
3564 X
3565 X int inum;
3566 {
3567 X kernsym gensym();
3568 X
3569 X /* char *malloc (); */
3570 X
3571 X if (tree == NULL) {
3572 X
3573 X if ((tree= (struct inode *)malloc(sizeof(struct inode))) == NULL) {
3575 X exit(1);
3576 X }
3577 X tree->inum = inum;
3578 X tree->sym = lastsym = gensym();
3579 X tree->left = tree->right = NULL;
3580 X }
3581 X else if (inum < tree->inum)
3582 X tree->left = addinum(tree->left,inum);
3583 X
3584 X else if (inum > tree->inum)
3585 X tree->right = addinum(tree->right, inum);
3586 X
3587 X else
3588 X lastsym = tree->sym;
3589 X
3590 X return (tree);
3591 } /* addinum */
3592 X
3593 X rtree
3594 addrnum (tree, rnum) /*'add real to real tree */
3595 X rtree tree;
3596 X real rnum;
3597 {
3598 X kernsym gensym();
3599 X /* char *malloc (); */
3600 X
3601 X if (tree == NULL) {;
3602 X
3603 X if ((tree= (struct rnode *)malloc(sizeof (struct rnode))) == NULL) {
3605 X exit (1);
3606 X }
3607 X tree->rnum = rnum;
3608 X tree->sym = lastsym = gensym();
3609 X tree->left = tree->right = NULL;
3610 X }
3611 X else if (rnum < tree->rnum)
3612 X tree->left = addrnum(tree->left,rnum);
3613 X
3614 X else if (rnum > tree->rnum)
3615 X tree->right = addrnum(tree->right,rnum);
3616 X
3617 X else
3618 X lastsym = tree->sym;
3619 X
3620 X return (tree);
3621 } /* addrnum */
3622 X
3623 X
3624 /* 154 */
3625 X kernsym
3626 gensym () /* generate a new symbol */
3627 {
3628 X static int num = 0;
3629 X
3630 X sprintf (strbuf, "s%04d" , num++ );
3631 X
3632 X return (mksym(strbuf) );
3633 X
3634 }/* gensym */
3635 X
3636 X
3637 gencode (forms, chan) /* generate code for forms */
3638 X kerncell forms;
3639 X iochan chan;
3640 {
3641 X while (ISlist (forms)) {
3642 X
3643 X bufprint (PRINC, chan, "eval (");
3644 X gencells (forms->CELLcar, chan);
3645 X
3647 X
3648 X forms = forms->CELLcdr;
3649 X }
3650 }/* genoode */
3651 X
3652 gencells (form, chan) /* qenerate cells for fonn */
3653 X kerncell form;
3654 X iochan chan;
3655 {
3656 X if (ISlist (form) ) {
3657 X bufprint (PRINC, chan, "mkcell(");
3658 X
3659 X gencells (form->CELLcar, chan);
3660 X
3661 X bufprint (PRINC, chan, ",");
3662 X
3663 X gencells (form->CELLcdr, chan);
3664 X
3665 X bufprint (PRINC, chan, "> ");
3666 X }
3667 X else
3668 X printaux (PRINC, form, chan);
3669 } /* gencells */
3670 X
3671 /* 155 */
3672 X
3673 gensyms (tree, chan) /* generate code for making symbols */
3674 X stree tree;
3675 X iochan chan;
3676 {
3677 X if (tree != NULL) {
3678 X bufprint (PRINC, chan, "kernsym %s = ",tree->sym->name);
3679 X
3681 X
3682 X gensyms (tree->left, chan);
3683 X
3684 X gensyms (tree->right, chan);
3685 X }
3686 } /* gensyms */
3687 X
3688 X
3689 genstrs (tree, chan) /* generate code for making strings */
3690 X stree tree;
3691 X iochan chan;
3692 {
3693 X if (tree != NULL) {
3694 X
3695 X bufprint (PRINC, chan, "kerncell %s = ", tree->sym->name);
3696 X
3698 X genstrs (tree->left , chan);
3699 X
3700 X genstrs (tree->right, chan);
3701 X }
3702 } /* genstrs */
3703 X
3704 X
3705 geninums (tree, chan) /* generate code for making :integers */
3706 X itree tree;
3707 X iochan chan ;
3708 {
3709 X if (tree != NULL) {
3710 X bufprint (PRINC, chan, "kerncell %s = " , tree->sym->name);
3711 X
3713 X geninums (tree->left, chan);
3714 X geninums (tree->right, chan);
3715 X }
3716 }/* genlrrums */
3717 X
3718 /* 156 */
3719 X
3720 genrnums (tree, chan) /* generate code for makinq reals */
3721 X rtree tree;
3722 X iochan chan;
3723 {
3724 X if (tree != NULL) {
3725 X
3726 X bufprint(PRINC, chan, "kerncell %s = ",tree->sym->name);
3728 X
3729 X genrnums (tree->left, chan);
3730 X
3731 X genrnums (tree->right, chan);
3732 X }
3733 } /* genrnums */
3734 X
3735 SHAR_EOF
3737 chmod 0644 'apli/kcomp.c'
3738 if test $? -ne 0
3740 fi
3742 then (
3744 ) << SHAR_EOF
3745 301453a05f1a81f7294b067075fedd8a apli/kcomp.c
3746 SHAR_EOF
3747 else
3750 fi
3751 fi
3752 # ============= apli/kern.c ==============
3755 else
3757 sed 's/^X//' << 'SHAR_EOF' > 'apli/kern.c' &&
3758 /*
3759 kern.c
3760 */
3761 #include "kernel.h"
3762 main ()
3763 {
3764 initialize ();
3765 topexec ();
3766 } /* main */
3767 X
3768 X
3769 X
3770 SHAR_EOF
3772 chmod 0644 'apli/kern.c'
3773 if test $? -ne 0
3775 fi
3777 then (
3779 ) << SHAR_EOF
3780 08db03171ebb5dd811c2e2ec1807526b apli/kern.c
3781 SHAR_EOF
3782 else
3785 fi
3786 fi
3787 # ============= apli/list.c ==============
3790 else
3792 sed 's/^X//' << 'SHAR_EOF' | uudecode &&
3793 begin 600 apli/list.c
3798 M87)G+3Y#14Q,8V%R"@D)"3H@*&%R9R`]/2!.24P@/R!.24P*"0D)"3H)0T].
3799 M5F-E;&P@*&5R<F]R("AC87)S>6TL(&5R<E]L:7-T+"!A<F<I("D@*2`I.PH*
3811 M(#\@87)G+3Y#14Q,8V%R(#H@87)G+3Y#14Q,8V1R*3L*"@D)96QS92!I9B`H
3824 M"@ER96=I<W1E<B!K97)N8V5L;"!A<F<Q(#T@05)';G5M,3L*"6ME<FYC96QL
3831 M8W1I;VYS("HO"@HO*B`H<G!L86-A("=L:7-T("=N97=H96%D*2`J+PH*"6ME
3832 M<FYC96QL"DQR<&QA8V$@*"D@"GL*"6ME<FYC96QL(&%R9S$@/2!!4D=N=6TQ
3837 M;F-E;&P@87)G,2`]($%21VYU;3$["@H)0TA%0TML87)G<R`H<G!L86-D<WEM
3846 M:V5R;F-E;&P@;&ES=#L*>PH):68@*&QI<W0@/2!.24PI"@D)<F5T=7)N("A.
3848 M(#T@;&ES="T^0T5,3&-D<CL*"@ER971U<FX@*&QI<W0I.PH*?2\J(&QA<W1P
3854 M:V5R;F-E;&P*3&-O;G,H*2`O*B`H8V]N<R`G97AP<B`G;&ES="D@*B\*>PH)
3855 M:V5R;F-E;&P@87)G,B`]($%21VYU;3(["@EK97)N8V5L;"!N97=C96QL.PH*
3856 M"4-(14-+;&%R9W,@*&-O;G-S>6TL(#(I.PH)0TA%0TML:7-T("AC;VYS<WEM
3857 M+"!A<F<R*3L*"@EN97=C96QL(#T@9G)E<VAC96QL("@I.PH*"6YE=V-E;&PM
3868 M<W0M/F9L86<@/2!,25-43T)*.PH*"0EL:7-T+3Y#14Q,8V%R(#T@87)G<W1K
3869 M(%MI9'@K*UT["@E]"@ER971U<FX@*')E<RD["GT@+RH@=FQI<W0@*B\*"@EK
3873 M*&QE;F=T:'-Y;2P@87)G*3L*"@EF;W(@*&QE;CTP.R!)4VQI<W0@*&%R9RD@
3885 M<&%I<B`H;&ES="DI+3Y#14Q,8V1R(#T@8V]P>71O<"`H87)G*3L*"7T*"7)E
3910 M("\J("AR96UO=F4@)V5L96T@)VQI<W0I("HO"GL*"6ME<FYC96QL(&%R9S$@
3923 M9')E;6]V92`H*2`O*B!^*"IR96UO=F4@XH"896QE;2`G;&ES="D@*B\*>PH)
3924 M:V5R;F-E;&P@87)G,2`]($%21VYU;3$["@ER96=I<W1E<B!K97)N8V5L;"!A
3936 M=6TR+"!A<F<S*2D["@I]+RIN<W5B<S$[*B\*"FME<FYC96QL"@HO*B`Y,2`V
3937 M+C$@3&ES="!F=6YC=&EO;G,@*B\*"G-U8G-T("AA<F<Q+&%R9S(L(&%R9S,I
3942 M/2!L:7-T(#T@9G)E<VAC96QL("@I.PH*"0EE;'-E('L*"0D);&ES="T^0T5,
3948 M"@H)"6%R9S,@/2!A<F<S+3Y#14Q,8V1R.PH)?0H)<F5T=7)N("AR97,I.PI]
3950 M)W1H:7,@)W1H870@XH"8;&ES="D@*B\*>PH):V5R;F-E;&P@87)G,R`]($%2
3964 M;F-E;&P@87)G(#T@05)';G5M,3L*"@EK97)N8V5L;"!R97,@/2!.24P["@H)
3981 M:7-T97(@:V5R;F-E;&P@87)G,B`]($%21VYU;3(["@H)0TA%0TML87)G<R`H
3982 M;65M8F5R<WEM+"`R*3L*"4-(14-+;&ES="`H;65M8F5R<WEM+"!A<F<R*3L*
3988 M<FYC96QL(&%R9S(@/2!!4D=N=6TR.PH*"4-(14-+;&%R9W,@*&UE;7%S>6TL
3989 M(#(I.PH)0TA%0TML:7-T("AM96UQ<WEM+"!A<F<R*3L*"@EW:&EL92`H25-L
4000 M<CL*"7)E9VES=&5R(&ME<FYC96QL(&QI<W0["GL*"7=H:6QE("A)4VQI<W0@
4001 M*&QI<W0I("D@>PH*"0EI9B`H97AP<B`]/2!L:7-T+3Y#14Q,8V%R*0H)"0ER
4009 M*B!,97$@*B\*"F5Q=6%L("AE>'!R,2P@97AP<C(I("\J(&5Q=6%L("AE>'!R
4010 M,2QE>'!R,BD@*B\*"7)E9VES=&5R(&ME<FYC96QL(&5X<'(Q+"!E>'!R,CL*
4020 M*3L*"@D)8V%S92!614-43U)/0DHZ"@D)"7L@<F5G:7-T97(@:6YT(&1I;2`]
4035 M969A=6QT.@H)"0D)<F5T=7)N("@P*3L*"7T*?2\J97%U86PJ+PH*"6ME<FYC
4056 `
4057 end
4058 SHAR_EOF
4060 chmod 0644 'apli/list.c'
4061 if test $? -ne 0
4063 fi
4065 then (
4067 ) << SHAR_EOF
4068 943fb8f425e970638c2440e087e93eac apli/list.c
4069 SHAR_EOF
4070 else
4073 fi
4074 fi
4075 # ============= apli/logic.c ==============
4078 else
4080 sed 's/^X//' << 'SHAR_EOF' > 'apli/logic.c' &&
4081 /* Condionals and logic
4082 X 105 */
4083 /*
4084 X logic.c
4085 X */
4086 #include "kernel.h"
4087 X
4088 X kerncell
4089 Ucond () /* (cond --clause1 ... --clausen-- ) */
4090 {
4091 X
4092 X register kerncell list = argstk [ argtop];
4093 X register kerncell clause;
4094 X
4095 X kerncell obj;
4096 X
4097 X while (ISlist (list) ) {
4098 X
4099 X clause = list->CELLcar;
4100 X
4101 X CHECKlist(condsym, clause);
4102 X
4103 X if ((obj = eval(clause->CELLcar) ) != NIL) {
4104 X
4105 X while (ISlist(clause = clause->CELLcdr) )
4106 X
4107 X obj = eval (clause->CELLcar);
4108 X
4109 X return (obj);
4110 X }
4111 X list = list->CELLcdr;
4112 X }
4113 X return (NIL);
4114 X
4115 } /* Ucond */
4116 X
4117 X kerncell
4118 Lnot () /* (not 'expr) */
4119 {
4120 X
4121 X CHECKlargs (notsym, 1);
4122 X
4123 X return(ARGnum1 == NIL ? TTT : NIL);
4124 } /* Lnot */
4125 X
4126 X
4127 X kerncell
4128 Uand () /* (and exprl ... exprn ) */
4129 {
4130 X register kerncell list = argstk[argtop];
4131 X kerncell obj = NIL;
4132 X
4133 X while (ISlist (list) ) {
4134 X
4135 X if ((obj = eval (list->CELLcar) ) == NIL)
4136 X return (NIL);
4137 X
4138 X list = list->CELLcdr;
4139 X }
4140 X
4141 X return (obj);
4142 } /* Uand */
4143 X
4144 X
4145 /* 106 Conditionals and Logic
4146 */
4147 X kerncell
4148 Uor () /* (or expr1 ... exprn) */
4149 {
4150 X register kerncell list = argstk [argtop];
4151 X kerncell obj;
4152 X
4153 X while (ISlist (list) ) {
4154 X
4155 X if ((obj = eval(list->CELLcar) ) != NIL)
4156 X return (obj);
4157 X
4158 X list = list->CELLcdr;
4159 X }
4160 X return (NIL);
4161 X
4162 } /* Uor */
4163 X
4164 X kerncell
4165 Limply () /* ( > 'expr1 'expr2) */
4166 {
4167 X CHECKlargs (implysym, 2);
4168 X return(ARGnum1 == NIL || ARGnum2 != NIL ? TTT : NIL);
4169 X
4170 } /* Limply */
4171 X
4172 X kerncell
4173 Lequiv () /* (< > 'expr1 'expr2) */
4174 {
4175 X kerncell arg1 = ARGnum1;
4176 X kerncell arg2 = ARGnum2;
4177 X
4178 X CHECKlargs (equivsym,2);
4179 X
4180 X return (arg1 == arg2 ||
4181 X arg1 != NIL && arg2 != NIL ? TTT: NIL);
4182 X
4183 } /* Lequiv */
4184 X
4185 X
4186 /* 107 Condirionah and logic */
4187 X
4188 X kerncell
4189 Uall () /* (all (var1 dcxal ... varn domn) expr1 ... exprn) */
4190 {
4191 X kerncell list = argstk [argtop];
4192 X
4193 X if (list == NIL || checkdoms (list->CELLcar) )
4194 X error (allsym, err_dom,0);
4195 X
4196 X return (all (list->CELLcar, list->CELLcdr) );
4197 } /* Uall */
4198 X
4199 X
4200 checkdoms (doms) /* check domain designators */
4201 X register kerncell doms;
4202 {
4203 X if (! ISlist (doms) )
4204 X return (1);
4205 X
4206 X do {
4207 X
4208 X if (! ISsym(doms->CELLcar) || ISconst (doms->CELLcar) ||
4209 X ! ISlist (doms = doms->CELLcdr) )
4210 X return (1);
4211 X
4212 X } while (ISlist (doms = doms->CELLcdr) );
4213 X
4214 X return (0);
4215 X
4216 } /* checkdoms */
4217 X
4218 X kerncell
4219 all (doms,body) /* universal quantifier */
4220 X kerncell doms, body;
4221 {
4222 X
4223 X kernsym sym = CONVsym(doms->CELLcar);
4224 X register kerncell dom = eval(doms->CELLcdr->CELLcar);
4225 X register kerncell list;
4226 X
4227 X kerncell res = TTT;
4228 X
4229 X VARpush (sym, sym->flag, sym->bind);
4230 X sym->flag = VARIABLE;
4231 X
4232 X /* 108 conditionals and Logic
4233 X */
4234 X
4235 X doms = doms->CELLcdr->CELLcdr;
4236 X
4237 X if (!ISlist(dom) && dom != NIL)
4238 X error (allsym, err_dom, 0);
4239 X
4240 X while (ISlist (dom) ) {
4241 X
4242 X sym->bind = dom->CELLcar;
4243 X
4244 X if (ISlist (doms) )
4245 X res = all(doms, body);
4246 X
4247 X else {
4248 X list = body ;
4249 X
4250 X while (ISlist (list) ) {
4251 X res = eval (list->CELLcar);
4252 X list = list->CELLcdr;
4253 X }
4254 X }
4255 X if (res == NIL)
4256 X break;
4257 X
4258 X dom = dom->CELLcdr;
4259 X }
4260 X VARpop();
4261 X
4262 X return(res);
4263 X
4264 } /* all */
4265 X
4266 X kerncell
4267 Uexist () /* (exist (var1 dc' [vari dc'.] ) expr ) */
4268 {
4269 X kerncell list = argstk [argtop];
4270 X
4271 X if (list == NIL || checkdoms (list->CELLcar) )
4272 X error (existsym, err_dom, 0);
4273 X
4274 X return (exist ( list->CELLcar, list->CELLcdr ) ) ;
4275 } /* Uexist */
4276 X
4277 /* 109 */
4278 X
4279 X kerncell
4280 exist (doms, body) /* existential quantifier */
4281 X kerncell doms, body;
4282 {
4283 X kernsym sym = CONVsym(doms->CELLcar) ;
4284 X register kerncell dom = eval(doms->CELLcdr->CELLcar);
4285 X register kerncell list;
4286 X kerncell res = NIL;
4287 X
4288 X VARpush (sym, sym->flag, sym->bind);
4289 X sym->flag = VARIABLE;
4290 X
4291 X doms = doms->CELLcdr->CELLcdr;
4292 X if (! ISlist (dom) && dom != NIL)
4293 X error (existsym, err_dom, 0);
4294 X
4295 X while (ISlist (dom) ) {
4296 X
4297 X sym->bind = dom->CELLcar;
4298 X
4299 X if (ISlist (doms) )
4300 X res = exist (doms,body);
4301 X
4302 X else {
4303 X list = body;
4304 X
4305 X while (ISlist (list) ) {
4306 X
4307 X res = eval (list->CELLcar);
4308 X
4309 X list = list->CELLcdr;
4310 X }
4311 X }
4312 X
4313 X if (res != NIL)
4314 X break;
4315 X
4316 X dom = dom->CELLcdr;
4317 X }
4318 X VARpop();
4319 X
4320 X return (res);
4321 } /* exist */
4322 X
4323 kerncell
4324 X
4325 Uone () /* (one (var1 doml deflt) exprl ... exprn) */
4326 {
4327 X register kerncell list = argstk[argtop];
4328 X register kerncell dom;
4329 X
4330 X kerncell body, deflt, res;
4331 X
4332 X kernsym sym;
4333 X
4334 X if (list == NIL || !ISlist(dom = list->CELLcar) ||
4335 X ! ISsym(sym = CONVsym(dom->CELLcar) ) || ISconst (sym) )
4336 X error (onesym, err_dom,0);
4337 X
4338 X deflt = eval(dom->CELLcdr->CELLcdr->CELLcar);
4339 X VARpush (sym, sym->flag, sym->bind);
4340 X
4341 X sym->flag = VARIABLE;
4342 X
4343 X dom = eval(dom->CELLcdr->CELLcar);
4344 X
4345 X if (! ISlist (dom) && dom != NIL)
4346 X error (onesym, err_dom, 0);
4347 X
4348 X body = list->CELLcdr;
4349 X
4350 X while (ISlist (dom) ) {
4351 X
4352 X /* 110 Conditionals and Logic */
4353 X
4354 X sym->bind = dom->CELLcar;
4355 X list = body;
4356 X
4357 X while (ISlist(list)) {
4358 X res = eval(list->CELLcar);
4359 X list = list->CELLcdr;
4360 X }
4361 X if (res != NIL)
4362 X break;
4363 X
4364 X dom = dom->CELLcdr;
4365 X }
4366 X VARpop ();
4367 X
4368 X return (ISlist (dom) ? dom->CELLcar: deflt);
4369 } /* one */
4370 X
4371 X
4372 X
4373 X
4374 X
4375 X
4376 X
4377 X
4378 X
4379 X
4380 X
4381 X
4382 X
4383 X
4384 X
4385 SHAR_EOF
4387 chmod 0644 'apli/logic.c'
4388 if test $? -ne 0
4390 fi
4392 then (
4394 ) << SHAR_EOF
4395 ad94a3c0751fa82b812ffd49e8c084fd apli/logic.c
4396 SHAR_EOF
4397 else
4400 fi
4401 fi
4402 # ============= apli/map.c ==============
4405 else
4407 sed 's/^X//' << 'SHAR_EOF' | uudecode &&
4408 begin 600 apli/map.c
4410 M;VX@*B\*+RH@;6%P+F,@*B\*"B-I;F-L=61E(")K97)N96PN:"(*"@EK97)N
4430 M3#L*"6EN="!A<F<Q(#T@05)':61X,2`K(#$["@EI;G0@87)G;B`](&%R9W1O
4441 M:&4@9G5N8W1I;VX@*B\*"0EA<F=T;W`@/2!A<F=N*S$[("\J(&ME97`@9G5N
4453 M"0EF;W(@*&D]87)G,3L@,2`\(&%R9VX[("LK:2D@>R`O*B!P<F5P87)E(&%R
4455 M72`](&%R9W-T:R!;:5T@+3Y#14Q,8V1R.PH)"7T*"0E!4D=P=7-H("A#3TY6
4465 M0TMV87)G<S$@*&UA<&-D<G-Y;2P@,BD[("\J(&%T(&QE87-T(#(@87)G<R!R
4471 M*B\*"@D)"4%21W!U<V@@*&%R9W-T:R!;:5T@*3L*"@D)"6%R9W-T:R!;:5T@
4478 `
4479 end
4480 SHAR_EOF
4483 if test $? -ne 0
4485 fi
4487 then (
4489 ) << SHAR_EOF
4490 2193261ceb6cc5ccd489630423ba0641 apli/map.c
4491 SHAR_EOF
4492 else
4495 fi
4496 fi
4497 # ============= apli/misc.c ==============
4500 else
4503 begin 600 apli/misc.c
4505 M=61E(")K97)N96PN:"(*"@EK97)N8V5L;`I5=F]I9"@I("\J("AV;VED(%ME
4515 M*&MW;W1E<WEM+"`Q*3L*"@ER971U<FX@*&UK8V5L;"`H<75O=&5S>6TL;6MC
4523 M36ES8V5L;&%N96]U<R`J+PH):V5R;F-E;&P*369U;B`H*2`O*@DH9G5N(&YA
4526 M969S>6TL"@D)"0DH25-S>6TH;&ES="T^0T5,3&-D<BT^0T5,3&-A<BD@)B8*
4539 M("AA<F=S=&M;:61X("L@87)G;G5M("T@,5TI.PH*?2\J3&%R<2HO"@HO*B`Q
4549 M=F%R<RT^0T5,3&-A<BDI('L*"@D)"6EF("@A25-S>6TH=F%R+3Y#14Q,8V%R
4551 M("AL971S>6TL(")B860@=F%R:6%B;&4@9F]R;2(L('9A<BD["@H)"0EP87)S
4555 M<G,I.PH)"0EI;FET<R`](&UK8V5L;"`H3DE,+"!I;FET<RD["@D)?0H)"65L
4561 M96QL"DQS970@*"D@+RH@*'-E="#B@)AS>6T@)V5X<'(I("HO"GL*"6ME<FYC
4562 M96QL(&%R9S$@/2!!4D=N=6TQ.PH*"6ME<FYC96QL(&%R9S(@/2!!4D=N=6TR
4563 M.PH*"4-(14-+;&%R9W,@*'-E='-Y;2P@,BD["@H)0TA%0TMS>6TR("AS971S
4565 M"@ER971U<FX@*$-/3E9S>6TH87)G,2D@+3YB:6YD(#T@87)G,BD["@I]("\J
4570 M97)R7V%R9W,L(#`I.PH*"7=H:6QE("A)4VQI<W0@*&QI<W0I("D@>PH*"0ES
4574 M>6TM/F9L86<@/2!605))04),13L*"@D)<F5S(#T@<WEM+3YB:6YD(#T@979A
4575 M;"`H;&ES="T^0T5,3&-A<BD["@H)"6QI<W0@/2!L:7-T+3Y#14Q,8V1R.PH)
4599 M+%]O=71C:&%N*3L*"@D)96QS92!["@H)"0EL96X@*ST@8G5F<')I;G0H4%))
4600 M3E0L7V]U=&-H86XL(B@B*3L*"@D)"7=H:6QE("A)4VQI<W0@*&9R86UE*2`I
4608 M;&ES="`H9G)A;64@/2!F<F%M92T^0T5,3&-D<BDI(`H)"0D)"6)U9G!R:6YT
4609 M("A04DE.5"Q?;W5T8VAA;BP@(B`B*3L*"0D)?0H)"0EB=69P<FEN="`H4%))
4618 M8F]S92D["@D)"6%R9S$@/2!A<F<Q+3Y#14Q,8V1R.PH)"7T*"65L<V4*"0EL
4628 M(G(B*2D@/3T@3E5,3"D*"0EE<G)O<BAL;V%D<WEM+")C86[B@)AT(&]P96X@
4630 M"@H)=VAI;&4@*"AO8FH@+2!R96%D875X*&-H86XL,"DI("$]($-/3E9C96QL
4638 M;&5N(#TP.PH*"7=H:6QE("A)4VQI<W0@*&QI<W0I*2!["@H)"7-T<B`]($=%
4644 M"@ER971U<FX@*&UK:6YU;2`H<W5B<VAE;&P@*'-T<F)U9BD@*2`I.PH*"GT@
4647 M+"!P<F]C:60L('-T871U<SL*"7)E9VES=&5R(&EN="!I=V%I=#L*"@ES879E
4658 `
4659 end
4660 SHAR_EOF
4662 chmod 0644 'apli/misc.c'
4663 if test $? -ne 0
4665 fi
4667 then (
4669 ) << SHAR_EOF
4670 73bbc93f876a6ae590fd1354603001e2 apli/misc.c
4671 SHAR_EOF
4672 else
4673 test `LC_ALL=C wc -c < 'apli/misc.c'` -ne 6887 && \
4675 fi
4676 fi
4677 # ============= apli/prop.c ==============
4680 else
4682 sed 's/^X//' << 'SHAR_EOF' > 'apli/prop.c' &&
4683 /* 112
4684 Property Lists, Association Lists and Vectors
4685 */
4686 X
4688 X
4689 X kerncell
4690 Lputprop () /* (putprop 'sym 'value 'property) */
4691 {
4692 X kerncell arg1 = ARGnum1;
4693 X kerncell arg2 = ARGnum2;
4694 X kerncell arg3 = ARGnum3;
4695 X register kerncell plist;
4696 X
4697 X CHECKlargs (putpropsym, 3);
4698 X
4699 X CHECKsym1 (putpropsym, arg1);
4700 X
4701 X plist = CONVsym(arg1)->prop;
4702 X
4703 X while (ISlist (plist) ) {
4704 X
4705 X if (equal (plist->CELLcar, arg3) )
4706 X return (plist->CELLcdr->CELLcar = arg2);
4707 X
4708 X plist = plist->CELLcdr->CELLcdr;
4709 X }
4710 X CONVsym(arg1)->prop = mkcell (arg3,mkcell (arg2, CONVsym(arg1)->prop) );
4711 X
4712 X return (arg2);
4713 X
4714 } /* Lputprop */
4715 X
4716 X
4717 X kerncell
4718 Lremprop () /* (remprop 'sym 'property) */
4719 {
4720 X kerncell arg1 = ARGnum1;
4721 X kerncell arg2 = ARGnum2;
4722 X register kerncell plist;
4723 X kerncell res;
4724 X
4725 X CHECKlargs (rempropsym,2);
4726 X
4727 X CHECKsym1 (rempropsym, arg1);
4728 X
4729 X plist = CONVsym(arg1) ->prop;
4730 X
4731 X if (equal(plist->CELLcar, arg2) ) {
4732 X CONVsym(arg1) ->prop = plist->CELLcdr->CELLcdr;
4733 X
4734 X return (plist);
4735 X }
4736 X else {
4737 X plist = plist->CELLcdr;
4738 X
4739 X while (ISlist (plist->CELLcdr) ) {
4740 X if (equal (plist->CELLcdr->CELLcar, arg2) ) {
4741 X
4742 X res = plist->CELLcdr;
4743 X
4744 X plist->CELLcdr = plist->CELLcdr->CELLcdr->CELLcdr;
4745 X
4746 X return (res);
4747 X }
4748 X plist = plist->CELLcdr->CELLcdr;
4749 X }
4750 X }
4751 X return (NIL);
4752 } /* Lrenprcp */
4753 X
4754 /* 113 8.1 Property lists
4755 */
4756 X
4757 X kerncell
4758 Lget () /* {get 'sym 'property) */
4759 {
4760 X register kerncell arg1 = ARGnum1;
4761 X kerncell arg2 = ARGnum2;
4762 X
4763 X CHECKlargs (getsym, 2);
4764 X
4765 X CHECKsym1 (getsym, arg1);
4766 X
4767 X arg1 = CONVsym(arg1) ->prop;
4768 X while (ISlist (arg1) ) {
4769 X
4770 X if (equal (arg1->CELLcar, arg2) )
4771 X
4772 X return (arg1->CELLcdr->CELLcar);
4773 X
4774 X arg1 = arg1->CELLcdr->CELLcdr;
4775 X }
4776 X return (NIL);
4777 } /* Lremprop */
4778 X
4779 kerncell
4780 Lplist () /* (plist 'sym) */
4781 {
4782 X kerncell arg = ARGnum1;
4783 X
4784 X CHECKlargs (plistsym, 1);
4785 X
4786 X CHECKsym1 (plistsym, arg);
4787 X
4788 X return (CONVsym(arg) ->prop);
4789 } /* Lplist */
4790 X
4791 X kerncell
4792 Lsetplist () /* (setplist 'sym 'plist} */
4793 {
4794 X kerncell arg1 = ARGnum1;
4795 X kerncell arg2 = ARGnum2;
4796 X
4797 X CHECKlargs (setplistsym, 2);
4798 X
4799 X CHECKsym1 (setplistsym, arg1);
4800 X
4801 X CHECKlist (setplistsym, arg2);
4802 X
4803 X return (CONVsym(arg1) ->prop = arg2);
4804 } /* setplist */
4805 X
4806 X
4807 X
4808 /* 114 Property Lists, Association Lists and Vectors
4809 */
4810 X kerncell
4811 Lassoc () /* (assoc 'key 'alist) */
4812 {
4813 X kerncell arg1 = ARGnum1;
4814 X register kerncell arg2 = ARGnum2;
4815 X
4816 X CHECKlargs (assocsym, 2);
4817 X CHECKlist (assocsym, arg2);
4818 X
4819 X while (ISlist (arg2) ) {
4820 X if ( !ISlist (arg2->CELLcar) )
4822 X
4823 X if (equal (arg1, arg2->CELLcar->CELLcar) )
4824 X return (arg2->CELLcar);
4825 X
4826 X arg2 = arg2->CELLcdr;
4827 X }
4828 X return (NIL);
4829 X
4830 } /* Lassoc */
4831 X
4832 X kerncell
4833 Lassq () /* (assq 'key 'enlist) */
4834 {
4835 X kerncell arg1 = ARGnum1;
4836 X register kerncell arg2 = ARGnum2;
4837 X
4838 X CHECKlargs(assqsym, 2);
4839 X CHECKlist (assqsym, arg2);
4840 X
4841 X while (ISlist(arg2)) {
4842 X
4843 X if ( !ISlist (arg2->CELLcar) )
4845 X
4846 X if (arg1 == arg2->CELLcar->CELLcar)
4847 X return (arg2->CELLcdr);
4848 X
4849 X arg2 = arg2->CELLcdr;
4850 X }
4851 X return(NIL);
4852 } /* Lassq */
4853 X
4854 SHAR_EOF
4856 chmod 0644 'apli/prop.c'
4857 if test $? -ne 0
4859 fi
4861 then (
4863 ) << SHAR_EOF
4864 6d5a2a50ca3e030cad16b410f603f7a1 apli/prop.c
4865 SHAR_EOF
4866 else
4867 test `LC_ALL=C wc -c < 'apli/prop.c'` -ne 3014 && \
4869 fi
4870 fi
4871 # ============= apli/set.c ==============
4874 else
4876 sed 's/^X//' << 'SHAR_EOF' > 'apli/set.c' &&
4877 /* 97 */
4878 X
4879 /* Set.C */
4880 X
4882 X
4883 X kerncell remrep (kerncell); /* remove repetitions frcm set */
4884 X
4885 X kerncell
4886 Lconvset () /* (convset 'list) */
4887 {
4888 X register kerncell arg = ARGnum1;
4889 X
4890 X kerncell res = NIL;
4891 X
4892 X CHECKlargs (convsetsym, 1);;
4893 X
4894 X CHECKlist (convsetsym, arg);
4895 X
4896 X while (ISlist (arg) ) {
4897 X
4898 X if (!member (arg->CELLcar, arg->CELLcdr) )
4899 X mkset (arg->CELLcar, res);
4900 X
4901 X arg = arg->CELLcdr;
4902 X }
4903 X return (res);
4904 X
4905 } /* convset */
4906 X
4907 X
4908 /* 98 */
4909 kerncell
4910 Ldconvset ( ) /* (*convset ' list) */
4911 {
4912 X register kerncell arg = ARGnum1;
4913 X
4914 X kerncell res;
4915 X
4916 X CHECKlargs (dconvsetsym, 1);
4917 X
4918 X CHECKlist (dconvsetsym, arg);
4919 X
4920 X while (member (arg->CELLcar, arg->CELLcdr) )
4921 X arg = arg->CELLcdr;
4922 X res = arg;
4923 X
4924 X while (ISlist (arg->CELLcdr) ) {
4925 X
4926 X if (member(arg->CELLcdr->CELLcar, arg->CELLcdr->CELLcdr) )
4927 X arg->CELLcdr = arg->CELLcdr->CELLcdr;
4928 X
4929 X else {
4930 X
4931 X arg->flag = SETOBJ;
4932 X arg = arg->CELLcdr;
4933 X }
4934 X }
4935 X if (ISlist (arg) )
4936 X arg->flag = SETOBJ;
4937 X
4938 X return (res);
4939 }/* Ldconvset */
4940 X
4941 kerncell
4942 Lconvlist () /* (convlist 'set) */
4943 {
4944 X register kerncell arg = ARGnum1;
4945 X
4946 X kerncell res = NIL;
4947 X
4948 X CHECKlargs (convlistsym, 1);
4949 X
4950 X CHECKlist (convlistsym, arg);
4951 X
4952 X /* 99 */
4953 X
4954 X while (ISlist (arg)) {
4955 X res = mkcell (arg->CELLcar, res);
4956 X
4957 X arg = arg->CELLcdr;
4958 X }
4959 X return (res);
4960 } /* Lconvlist */
4961 X
4962 X kerncell
4963 Ldconvlist () /* (*C0nvlist '8et) */
4964 {
4965 X register kerncell arg = ARGnum1;
4966 X
4967 X kerncell res = arg;
4968 X
4969 X CHECKlargs (dconvlistsym, 1);
4970 X
4971 X CHECKlist (dconvlistsym, arg);
4972 X
4973 X while (ISlist (arg) ) {
4974 X
4975 X arg->flag = LISTOBJ;
4976 X
4977 X arg = arg->CELLcdr;
4978 X }
4979 X return (res);
4980 } /* Ldconvllst */
4981 X
4982 kerncell
4983 Veset () /* (eset 'expr1 ... exprn) */
4984 {
4985 X register int idx = ARGidx1;
4986 X
4987 X register kerncell res = NIL;
4988 X
4989 X while (idx < argtop)
4990 X res = mkset (argstk[idx++] ,res);
4991 X
4992 X return (remrep (res) );
4993 } /* Veset */
4994 X
4995 X kerncell
4996 remrep (set) /* remove repetitions frcm set */
4997 X register kerncell set;
4998 {
4999 X kerncell res;
5000 X
5001 X while (member (set->CELLcar, set->CELLcdr) )
5002 X set = set->CELLcdr;
5003 X
5004 X res = set;
5005 X
5006 X while (ISlist (set->CELLcdr) ) {
5007 X
5008 X if (member (set->CELLcdr->CELLcar, set->CELLcdr->CELLcdr) )
5009 X set->CELLcdr = set->CELLcdr->CELLcdr;
5010 X
5011 X else
5012 X set = set->CELLcdr;
5013 X }
5014 X return (res);
5015 } /* remrep */
5016 X
5017 X
5018 /* 100 */
5019 X kerncell
5020 Uiset () /* (iset expr (varl doml exprl exprfl) */
5021 {
5022 X kerncell list = argstk[argtop];
5023 X
5024 X if (checkdoms (list->CELLcdr->CELLcar) )
5025 X error (isetsym, err_dom, 0);
5026 X
5027 X return (iset (list->CELLcar,
5028 X list->CELLcdr->CELLcar,
5029 X list->CELLcdr->CELLcdr) );
5030 X
5031 } /* Uiset */
5032 X
5033 X kerncell
5034 iset (gen, doms, body) /* lmplicii' set construction */
5035 X kerncell gen, doms, body;
5036 {
5037 X kernsym sym = CONVsym(doms->CELLcar);
5038 X
5039 X register kerncell dom = eval (doms->CELLcdr->CELLcar);
5040 X
5041 X register kerncell list;
5042 X
5043 X kerncell tmp, res = NIL;
5044 X
5045 X VARpush (sym, sym->flag, sym->bind);
5046 X
5047 X sym->flag = VARIABLE;
5048 X
5049 X doms = doms->CELLcdr->CELLcdr;
5050 X
5051 X if (!ISlist(dom) && dom != NIL)
5052 X error (isetsym, err_dom, 0);
5053 X
5054 X while (ISlist(dom)) {
5055 X sym->bind = dom->CELLcar;
5056 X
5057 X /* 101 */
5058 X
5059 X if (ISlist (doms) )
5060 X res = unionaux(iset (gen,doms,body) ,res);
5061 X
5062 X else{
5063 X list= body;
5064 X while (ISlist (list)) {
5065 X tmp = eval (list->CELLcar);
5066 X list = list->CELLcdr;
5067 X }
5068 X if (tmp != NIL)
5069 X res = mkset (eval (gen) , res);
5070 X }
5071 X dom = dom->CELLcdr;
5072 X }
5073 X VARpop();
5074 X return(ISlist(doms) ? res : remrep(res));
5075 }/* 1Set */
5076 X
5077 X kerncell
5078 unionaux (set1, set2) /* unlon or setl and set2 */
5079 X register kerncell set1, set2;
5080 {
5081 X while (ISlist (set1) ) {
5082 X
5083 X if (!member(set1->CELLcar, set2) )
5084 X set2 = mkset (set1->CELLcar, set2);;
5085 X
5086 X set1 = set1->CELLcdr;
5087 X }
5088 X return ( set2);
5089 } /* unlonaux */
5090 X
5091 X kerncell
5092 Vunion () /* (union ' setl setn) */
5093 {
5094 X register int idx = ARGidx1;
5095 X register kerncell argi;
5096 X kerncell res;
5097 X
5098 X if (idx == argtop)
5099 X return (NIL);
5100 X
5101 X if (idx+1 == argtop)
5102 X return (ARGnum1);
5103 X
5104 X res = ARGnum1;
5105 X
5106 X CHECKlist (unionsym, res);
5107 X
5108 X while (++idx < argtop) {
5109 X argi = argstk [idx];
5110 X
5111 X CHECKlist (unionsym, argi);
5112 X
5113 X while (ISlist (argi) ) {
5114 X
5115 X if (!member(argi->CELLcar, res) )
5116 X res = mkset(argi->CELLcar, res);
5117 X
5118 X argi = argi->CELLcdr;
5119 X }
5120 X }
5121 X return (res);
5122 }/* Vunion */
5123 X
5124 X
5125 /* 102 */
5126 X
5127 X kerncell
5128 Vintsec () /* (intsec ' setl setn) */
5129 {
5130 X register int idx = ARGidx1;
5131 X register kerncell argi;
5132 X kerncell tmp, res;
5133 X
5134 X if (idx == argtop )
5135 X return (NIL);
5136 X
5137 X if (idx+1 == argtop)
5138 X return (ARGnum1);
5139 X
5140 X tmp=ARGnum1;
5141 X
5142 X CHECKlist (intsecsym, tmp);
5143 X
5144 X while (++idx < argtop ) {
5145 X
5146 X argi = argstk [idx];
5147 X
5148 X CHECKlist (intsecsym, argi);
5149 X res =NIL;
5150 X
5151 X while (ISlist (argi)) {
5152 X
5153 X if (member(argi->CELLcar,tmp) )
5154 X res = mkset(argi->CELLcar, res);
5155 X
5156 X argi = argi->CELLcdr;
5157 X }
5158 X tmp = res;
5159 X }
5160 X return (res);
5161 X
5162 } /* Vintsec */
5163 X
5164 /* 103 */
5165 X kerncell
5166 Ldiff () /* (diff 'set1 'set2) */
5167 {
5168 X register kerncell arg1 = ARGnum1;
5169 X kerncell arg2 = ARGnum2;
5170 X kerncell res = NIL;
5171 X
5172 X CHECKlargs (diffsym, 2);
5173 X CHECKlist (diffsym, arg1);
5174 X CHECKlist (diffsym, arg2);
5175 X
5176 X while (ISlist (arg1)) {
5177 X
5178 X if (!member(arg1->CELLcar, arg2) )
5179 X res = mkset (arg1->CELLcar, res);
5180 X
5181 X arg1 = arg1->CELLcdr;
5182 X }
5183 X return (res);
5184 } /* Ldiff */
5185 X
5186 X kerncell
5187 Lsubset () /* (subset 'set1 'set2) */
5188 {
5189 X register kerncell arg1 = ARGnum1;
5190 X kerncell arg2 = ARGnum2;
5191 X
5192 X CHECKlargs (subsetsym,-2);
5193 X CHECKlist (subsetsym, arg1);
5194 X CHECKlist (subsetsym, arg2);
5195 X
5196 X while (ISlist (arg1) ) {
5197 X
5198 X if (!member(arg1->CELLcar,arg2) )
5199 X return (NIL);
5200 X
5201 X arg1 = arg1->CELLcdr;
5202 X }
5203 X return (TTT);
5204 X
5205 } /* LSubSet */
5206 X
5207 SHAR_EOF
5209 chmod 0644 'apli/set.c'
5210 if test $? -ne 0
5212 fi
5214 then (
5216 ) << SHAR_EOF
5217 ab9c444703c1f8af14454ea6671d80a5 apli/set.c
5218 SHAR_EOF
5219 else
5220 test `LC_ALL=C wc -c < 'apli/set.c'` -ne 5265 && \
5222 fi
5223 fi
5224 # ============= apli/str.c ==============
5227 else
5229 sed 's/^X//' << 'SHAR_EOF' > 'apli/str.c' &&
5230 X
5231 /* 75
5232 X $.2 String functions
5233 X str.c
5234 X */
5235 X
5237 X
5238 X kerncell
5239 Ls_lt () /* (<< 'str1 'str2) */
5240 {
5241 X
5242 X kerncell arg1 = ARGnum1;
5243 X kerncell arg2 = ARGnum2;
5244 X
5245 X CHECKlargs(s_ltsym, 2);
5246 X
5247 X return (strcmp (GETstr (s_ltsym, arg1),
5248 X
5249 X GETstr(s_ltsym,arg2)) < 0 ? TTT: NIL);
5250 X
5251 } /* Ls_lt */
5252 X
5253 X kerncell
5254 Ls_gt () /* (>> 'strl 'str2) */
5255 {
5256 X kerncell arg1 = ARGnum1;
5257 X kerncell arg2 = ARGnum2;
5258 X
5259 X CHECKlargs(s_gtsym,2);
5260 X
5261 X return (strcmp (GETstr (s_gtsym, arg1),
5262 X GETstr(s_gtsym,arg2)) > 0 ? TTT: NIL);
5263 X
5264 } /* Ls_gt */
5265 X
5266 X
5267 X kerncell
5268 Ls_eq () /* ( == 'strl 'str2) */
5269 {
5270 X kerncell arg1 = ARGnum1;
5271 X kerncell arg2 = ARGnum2;
5272 X
5273 X CHECKlargs(s_eqsym, 2);
5274 X
5275 X return (strcmp (GETstr (s_eqsym, arg1),
5276 X GETstr (s_eqsym,arg2) ) == 0 ? TTT: NIL);
5277 X
5278 } /* Ls_eq */
5279 X
5280 X kerncell
5281 Lstrcmp () /* (strcmp 'strl 'str2) */
5282 {
5283 X kerncell arg1 = ARGnum1;
5284 X kerncell arg2 = ARGnum2;
5285 X
5286 X CHECKlargs(strcmpsym, 2);
5287 X
5288 X return (mkinum(strcmp (GETstr (strcmpsym, arg1),
5289 X GETstr(strcmpsym, arg2))));
5290 X
5291 } /* Lstrcmp */
5292 X
5293 X
5294 /* 76
5295 X Arithmetic, Strings_and SYmbols
5296 X */
5297 X kerncell
5298 Lnthchar () /* (nthchar 'str 'n) */
5299 {
5300 X
5301 X kerncell arg1 = ARGnum1;
5302 X kerncell arg2 = ARGnum2;
5303 X register char *str;
5304 X register int n;
5305 X
5306 X CHECKlargs(nthcharsym, 2);
5307 X
5308 X str = GETstr (nthcharsym, arg1);
5309 X n = GETint(nthcharsym, arg2);
5310 X
5311 X while (n > 0 && *str != 0) {
5312 X --n;
5313 X ++str;
5314 X }
5315 X return (mkinum(CONVint(*str)));
5316 } /* Lnthchar */
5317 X
5318 kerncell
5319 Lsubstr () /* (substr 'str 'i 'j) */
5320 {
5321 X
5322 X kerncell arg1 = ARGnum1;
5323 X kerncell arg2 = ARGnum2;
5324 X kerncell arg3 = ARGnum3;
5325 X register char *str;
5326 X
5327 X /* 77
5328 X 5.2 Strfng functions
5329 X */
5330 X
5331 X register int m, n;
5332 X
5333 X CHECKlargs(substrsym, 3);
5334 X str = GETstr (substrsym, arg1);
5335 X m = GETint (substrsym, arg2);
5336 X n = GETint (substrsym, arg3);
5337 X while (m > 0 && *str != 0) { /* skip the first m chars_*/
5338 X --m;
5339 X ++str;
5340 X }
5341 X if ((m = 0) >n) /* negative rarxye? */
5342 X strbuf[0] = 0;
5343 X
5344 X else { /* copy the substring to strbuf */
5345 X
5346 X while (m < n && *str)
5347 X strbuf[m++] = *str++;
5348 X
5349 X strbuf [m] = 0;
5350 X }
5351 X return (mkstr (strbuf ) );
5352 } /* Lsubstr */
5353 X
5354 X
5355 X
5356 X
5357 X kerncell
5358 Lstrlen () /* (strlen 'str) */
5359 {
5360 X kerncell arg = ARGnum1;
5361 X
5362 X CHECKlargs(strlensym, 1);
5363 X return (mkinum(strlen(GETstr (strlensym, arg))));
5364 X
5365 } /* Lstrlen */
5366 X
5367 X kerncell
5368 Lstrconc () /* (strconc 'strl 'str2) */
5369 {
5370 X kerncell arg1 = ARGnum1;
5371 X kerncell arg2 = ARGnum2;
5372 X char *strl, *str2;
5373 X int m, n;
5374 X
5375 X CHECKlargs(strconcsym, 2);
5376 X m = strlen (strl = GETstr(strconcsym, arg1) );
5377 X n = strlen(str2 = GETstr(strconcsym,arg2));
5378 X
5379 X if (m+n > STRBUFSIZE)
5381 X
5382 X strcpy (strbuf, strl);
5383 X strcpy (strbuf, str2);
5384 X strbuf [m + n] = 0;
5385 X
5386 X return (mkstr (strbuf ) );
5387 X
5388 } /* Lstrconc */
5389 X
5390 /* 78 Arithmetic, Strings_and Symbols
5391 */
5392 X kerncell
5393 Lnilstrp () /* (nilstr? 'str) */
5394 {
5395 X kerncell arg = ARGnum1;
5396 X
5397 X CHECKlargs(nilstrpsym, 1);
5398 X
5399 X return(*(GETstr(nilstrpsym, arg)) == 0 ? TTT: NIL);
5400 } /* Lnilstrp */
5401 X
5402 X kerncell
5403 Lstringp () /* (string? 'str) */
5404 {
5405 X CHECKlargs(stringpsym, 1);
5406 X return(ISstr(ARGnum1) ? TTT: NIL);
5407 X
5408 } /* Lstringp */
5409 X
5410 X
5411 X
5412 SHAR_EOF
5414 chmod 0644 'apli/str.c'
5415 if test $? -ne 0
5417 fi
5419 then (
5421 ) << SHAR_EOF
5422 ac2e03b08891d0f4a7662d97f494572d apli/str.c
5423 SHAR_EOF
5424 else
5425 test `LC_ALL=C wc -c < 'apli/str.c'` -ne 2993 && \
5427 fi
5428 fi
5429 # ============= apli/sym.c ==============
5432 else
5434 sed 's/^X//' << 'SHAR_EOF' > 'apli/sym.c' &&
5435 /* 79 5.9 Symbol functions */
5436 /* sym.c */
5437 X
5439 X
5440 X kerncell
5441 Lsymname () /* (symnane 'syn) */
5442 {
5443 X kerncell arg = ARGnum1;
5444 X
5445 X CHECKlargs (symnamesym, 1);
5446 X
5447 X CHECKsym1 (symnamesym, arg);
5448 X
5449 X return (mkstr (CONVsym(arg) ->name) );
5450 } /* Lsymnane */
5451 X
5452 X kerncell
5453 Usynonym () /* (synonym sym1 sym2) */
5454 {
5455 X kerncell list = argstk[argtop];
5456 X kernsym sym1, sym2;
5457 X
5458 X if (list->CELLcdr == NIL || list->CELLcdr->CELLcdr != NIL)
5459 X error (synonymsym, err_args, 0);
5460 X
5461 X sym1 = CONVsym(list->CELLcar);
5462 X sym2 = CONVsym(list->CELLcdr->CELLcar);
5463 X
5464 X CHECKsym2 (symnamesym, sym1);
5465 X CHECKsym1 (symnamesym, sym2);
5466 X
5467 X sym1->flag = sym2->flag;
5468 X sym1->bind = sym2->bind;
5469 X sym1->prop = sym2->prop;
5470 X
5471 X return (CONVcell (sym1) );
5472 X
5473 } /* Usynonym */
5474 X
5475 X kerncell
5476 Lgensym () /* (gensym) */
5477 {
5478 X static int num = 0;
5479 X
5480 X CHECKlargs (gensymsym, 0);
5481 X
5483 X
5484 X return (CONVcell (mksym(strbuf ) ) );
5485 } /* Lgensym */
5486 X
5487 /* Arithmetic, Strings and SYmbols
5488 X 80 */
5489 X kerncell
5490 Vconcat () /* (concat 'strl ... 'strn) */
5491 {
5492 X
5493 X kerncell arg;
5494 X register int idx = ARGidx1;
5495 X
5496 X int len= 0;
5497 X
5498 X char *str;
5499 X char *buf = strbuf;
5500 X
5501 X CHECKvargs1 (concatsym, 1);
5502 X
5503 X while (idx < argtop) {
5504 X
5505 X arg = argstk [idx++] ;
5506 X str = GETstr (concatsym, arg);
5507 X
5508 X if ((len += strlen(str) ) > STRBUFSIZE)
5510 X
5512 X buf = strbuf + len;
5513 X }
5514 X return (CONVcell(mksym(strbuf) ) );
5515 } /* Vconcat */
5516 X
5517 X kerncell
5518 Lbinding () /* (binding 'expr) */
5519 {
5520 X
5521 X kerncell arg = ARGnum1;
5522 X
5523 X CHECKlargs (bindingsym, 1);
5524 X
5525 X
5526 X /* 81 5.3 Symbol functions */
5527 X
5528 X switch (arg->flag) {
5529 X
5530 X case CONSTANT:
5531 X case VARIABLE:
5532 X case FUNCTION:
5533 X return (CONVsym(arg)->bind);
5534 X
5535 X case LBINARY:
5538 X
5542 X
5546 X
5550 X
5551 X default:
5553 X }
5555 X
5556 X kerncell
5558 {
5559 X kerncell arg = ARGnum1;
5560 X
5561 X CHECKlargs (symbolpsym, 1);
5562 X return(ISsym(arg) ? TTT: NIL);
5563 X
5564 } /* Lsymbolp */
5565 X
5566 X kerncell
5568 {
5570 X
5573 X
5576 X
5577 SHAR_EOF
5582 fi
5587 5ff4558249bfb4815e0cc4bfdc389965 apli/sym.c
5588 SHAR_EOF
5589 else
5592 fi
5593 fi
5594 # ============= apli/symt.c ==============
5597 else
5601 X
5602 #include "kernel.h"
5603 extern kernsym _tempsym;
5604 X
5606 X
5608 X
5609 initsymtab ()
5610 {
5611 X register int i;
5612 X
5615 X
5617 X
5620 {
5622 X
5627 X
5628 X kernsym
5631 {
5633 X int len;
5635 X
5637 X
5639 X
5643 X
5653 X ;
5656 X }
5658 X
5661 X
5662 X kernsym
5665 {
5668 X
5671 X
5674 X
5677 X
5678 X
5679 X
5683 {
5685 X
5691 X }
5692 X }
5695 X
5696 X kernsym
5699 {
5700 X
5702 X
5704 X
5706 X
5707 X kernsym
5710 X byte flag;
5712 {
5713 X kernsym sym;
5714 X
5718 X
5721 X
5722 X
5723 SHAR_EOF
5728 fi
5733 1d5903a9b5becbcbba92f94380ff0300 apli/symt.c
5734 SHAR_EOF
5735 else
5738 fi
5739 fi
5740 # ============= apli/vec.c ==============
5743 else
5748 X
5749 #include "kernel.h"
5750 X
5751 X kerncell
5753 {
5754 X kerncell arg = ARGnum1;
5755 X kerncell vector, *vec;
5756 X register int dim;
5757 X
5758 X CHECKlargs (vectorsym, 1);
5759 X
5760 X if ( !ISint(arg) || (dim = arg->CELLinum) <= 0)
5761 X error (vectorsym, "bad dimension", arg);
5762 X
5763 X vec = CONVvector(new(sizeof (kerncell) * dim) );
5764 X
5765 X vector = freshcell ();
5766 X
5767 X vector->flag = VECTOROBJ;
5768 X
5769 X vector->CELLdim = arg;
5770 X vector->CELLvec = vec;
5771 X
5772 X while (dim-- ) /* initialize all slots to nil */
5773 X *vec++ = NIL;
5774 X
5775 X return (vector);
5776 X
5777 } /* Lvector */
5778 X
5779 X
5780 X
5781 /* 116 Property Lists Association Lists and Vectors */
5782 X kerncell
5784 {
5785 X
5789 X
5793 X
5799 X
5801 X
5802 X
5803 kerncell
5804 X
5806 {
5807 X
5808 X kerncell arg = ARGnum1;
5809 X kerncell *vec;
5810 X
5811 X CHECKlargs (dimensionsym, 1);
5812 X
5813 X if (! ISvector (arg) )
5814 X
5815 X error (dimensionsym, "non-vector argument", arg);
5816 X
5817 X return (arg->CELLdim);
5818 X
5819 } /* Ldimension */
5820 X
5821 X kerncell
5823 {
5824 X
5826 X
5829 X
5831 X
5832 X
5833 SHAR_EOF
5838 fi
5843 adbe04b3f663596948c00decb5231010 apli/vec.c
5844 SHAR_EOF
5845 else
5848 fi
5849 fi
5850 # ============= apli/kernel.h ==============
5853 else
5857 // Appendix A
5858 // Global Definitions
5859 X
5860 #define DEBUG
5862 #ifdef DEBUG
5863 # define DBG(s) printf("%s\n", (s));
5864 #else
5865 # define DBG(s) ;
5866 #endif DEBUG
5867 X
5869 #include <stdio.h>
5870 #include <stdlib.h>
5871 #include <string.h>
5872 X
5873 X
5874 #define UNIX YES
5876 X
5877 #define HASHTABSIZE 256 /* size of hash table */
5878 #define CELLTABSIZE 1024 /* Size of cell table */
5879 #define BLOCKSIZE 512 /* block size for cell allocation */
5880 #define EVALSTKSIZE 1024 /* size of evaluation stack */
5881 #define VARSTKSIZE 1024 /* size of variable stack */
5882 #define ARGSTKSIZE 1024 /* size of argument stack */
5883 #define CATSTKSIZE 256 /* size of catch stack */
5884 #define CHANBUFSIZE 126 /* size of channel buffer */
5885 #define STRBUFSIZE 126 /* size of string buffer */
5886 #define MAXCOLS 80 /* max no. of columns on the screen */
5887 #define SMALLINTLOW -128 /* least small integer */
5888 #define SMALLINTHIGH 127 /* greatest small integer */
5889 X
5891 #define UNBOUND 0 /* unbound symbol */
5892 #define CONSTANT 1 /* constant - cannot be changed */
5893 #define VARIABLE 2 /* bound variable */
5894 #define FUNCTION 3 /* non-binary function */
5895 #define LBINARY 4 /* binary lam */
5896 #define VBINARY 5 /* binary vlam */
5897 #define UBINARY 6 /* binary ulam */
5898 #define MBINARY 7 /* binary mlam */
5899 #define INTERNAL 8 /* internal object - not in symbol table */
5900 X
5902 #define VOID 10 /* void dbject */
5903 #define INTOBJ 11 /* integer number */
5904 #define REALOBJ 12 /* real number */
5905 #define STROBJ 13 /* string */
5906 #define CHANOBJ 14 /* channel for I/O */
5907 #define VECTOROBJ 15 /* vector */
5908 X
5910 X
5911 #define LISTOBJ 16 /* list */
5912 #define SETOBJ 17 /* set */
5913 #define MARK 128 /* mark bit - for garbage collection */
5914 #define MASK7 127 /* for masking bit 7 in flag */
5915 X
5917 #define INCHAN 0 /* input channel flag */
5918 #define OUTCHAN 1 /* output channel flag */
5919 #define INOUTCHAN 2 /* input-Output channel flag */
5920 X
5922 #define PRINT 0 /* flag === PRINT ===> prim; */
5923 #define PRINC 1 /* flag == PRINC ==> princ */
5924 #define LENGTH 2 /* flag == LENGTH ==> prlen */
5925 #define STRIP 3 /* |symbol => symbol */
5926 X
5930 X
5937 };
5938 X
5941 X union {
5955 };
5956 X
5966 };
5967 X
5972 };
5973 X
5977 X
5979 X
5980 #define ISnotbinary(p) ((p)->flag < LBINARY)
5981 #define ISunbound(p) ((p)->flag == UNBOUND)
5982 #define ISconst(p) ((p)->flag == CONSTANT)
5983 #define ISvar(p) ((p)->flag == VARIABLE)
5984 #define ISfun(p) ((p)->flag == FUNCTION)
5985 #define ISlbin(p) ((p)->flag == LBINARY)
5986 #define ISvbin(p) ((p)->flag == VBINARY)
5987 #define ISubin(p) ((p)->flag == UBINARY)
5988 #define ISmbin(p) ((p)->flag == MBINARY)
5989 #define ISinternal(p) ((p)->flag == INTERNAL)
5990 X
5991 #define ISsym(p) ((p)->flag < VOID)
5992 #define IScell(p) ((p)->flag >= VOID)
5993 #define ISvoid(p) ((p)->flag == VOID)
5994 #define ISint(p) ((p)->flag == INTOBJ)
5995 #define ISreal(p) ((p)->flag == REALOBJ)
5996 #define ISstr(p) ((p)->flag == STROBJ)
5997 #define ISchan(p) ((p)->flag == CHANOBJ)
5998 #define ISvector(p) ((p)->flag == VECTOROBJ)
5999 #define ISlist(p) ((p)->flag >= LISTOBJ)
6000 #define ISset(p) ((p)->flag == SETOBJ)
6001 #define ISmarked(p) (((p)->flag & MARK) == MARK)
6002 X
6003 #define CELLinum part.inum
6004 #define CELLrnum part.rnum
6005 #define CELLstr part.str
6006 #define CELLchan part.chan
6007 #define CELLcar part.pair.car
6008 #define CELLcdr part.pair.cdr
6009 #define CELLdim part.vect.dim
6010 #define CELLvec part.vect.vec
6011 X
6012 #define CONVbyte(p) ((byte) (p))
6013 #define CONVint(p) ((int) (p))
6014 #define CONVintp(p) ((int *) (p))
6015 #define CONVreal(p) ((real) (p))
6016 #define CONVstr(p) ((char *) (p))
6017 #define CONVchan(p) ((iochan) (p))
6018 X
6019 X
6020 X
6022 X
6023 #define CONVsym(p) ((kernsym) (p) )
6024 #define CONVcell(p) ((kerncell) (p) )
6025 #define CONVvector(p) ((kerncell *) (p) )
6026 #define NIL ((kerncell) nil)
6027 #define TTT ((kerncell) ttt)
6028 X
6029 #define READin() readaux(_inchan, 0)
6030 #define READchan(chan) readaux((chan)->KELLchan,0)
6031 #define PRINTout(p) printaux(PRINT, (p), _outchan)
6032 #define PRINTchan(p, chan) printaux(PRINT, (p), (chan)->CELLchan)
6033 #define TERPRIout() bufprint(PRINT, _outchan, "\n", 0)
6034 #define TERPRIchan(chan) bufprint(PRINT, (chan)->CELLchan, "\n", 0)
6035 #define INTERNALsym(isym) \
6037 X
6038 #define CHECKlargs(fun, n) \
6041 X
6042 #define CHECKvargs(fun, m, n) \
6046 X
6047 #define CHECKvargs1(fun, n) \
6050 X
6051 #define CHECKvargs2(fun, n) \
6054 X
6055 X
6056 #define EVALpush(obj) \
6059 X
6060 #define EVALpop() --evaltop
6061 X
6062 #define CELLpush(obj) \
6065 X
6066 #define CELLpop() ++celltop
6067 X
6068 #define VARpush(s, f,b) \
6074 X
6075 #define VARpop() \
6078 X
6079 #define ARGpush(obj) \
6082 X
6083 #define ARGpop() --argtop
6084 X
6085 #define ARGSpop() argtop=CONVint(argstk[argtop])-1
6086 X
6087 #define ARGidx1 CONVint(argstk[argtop])
6088 #define ARGnum1 argstk[ARGidx1]
6089 X
6091 X
6092 #define ARGnum2 argstk [ARGidx1 + 1]
6093 #define ARGnum3 argstk [ARGidx1 + 2]
6094 #define ARGnum4 argstk [ARGidx1 + 3]
6095 X
6096 #define GETint(yyy, xxx) \
6098 X
6099 #define GETreal(yyy, xxx) \
6101 X
6102 #define GETnum(yyy, xxx) \
6106 X
6107 #define GETstr(yyy, xxx) \
6111 X
6112 #define GETchan(yyy, xxx) \
6114 X
6115 #define CHECKsym1(yyy, xxx) \
6117 X
6118 #define CHECKsym2(yyy, xxx) \
6121 X
6122 #define CHECKpair(yyy, xxx) \
6124 X
6125 #define CHECKlist(yyy, xxx) \
6127 X
6129 X
6130 extern char
6136 X
6137 extern kerncell catres;
6138 extern kerncell golabel;
6139 extern kerncell _tempstr;
6142 extern char strbuf [];
6143 extern struct variable varstk [];
6148 X
6149 X
6154 X
6155 X
6157 X Global Definitions
6158 X */
6159 X
6162 X
6165 X
6168 X
6173 X
6176 X
6183 X
6187 X Vpp();
6188 X
6190 X
6195 X
6201 X
6205 X
6209 X
6213 X
6216 X
6224 X
6227 X
6229 X Appendix A */
6230 X
6236 X
6240 X
6244 X
6248 X
6251 X
6255 X
6258 X
6261 X
6263 X
6267 X
6271 X
6274 X
6276 X
6279 X
6281 X
6285 X
6288 SHAR_EOF
6293 fi
6298 93828e9ebd2feb45d6a78f849fc292a7 apli/kernel.h
6299 SHAR_EOF
6300 else
6303 fi
6304 fi
6305 # ============= apli/README ==============
6308 else
6312 LISP A Portable Implementation
6314 X
6315 X The license of the code is belonged to the author of the book.
6316 X
6318 I used several weeks to ocr and compile the source code.
6319 X
6323 X
6325 X
6326 SHAR_EOF
6331 fi
6336 99cb31c982127f1e4b59e5a835a3ec26 apli/README
6337 SHAR_EOF
6338 else
6341 fi
6342 fi
6343 # ============= apli/Makefile ==============
6346 else
6350 X list.c logic.c map.c misc.c prop.c set.c str.c sym.c symt.c vec.c
6352 CC = cc
6355 X
6356 X.SILENT:
6357 X
6358 all: kern kcomp
6359 X
6362 X
6365 X
6368 X
6369 clean:
6371 X
6372 SHAR_EOF
6377 fi
6382 533a85be7681edf78fd6d9a50abce0eb apli/Makefile
6383 SHAR_EOF
6384 else
6387 fi
6388 fi
6393 fi