home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 October / usenetsourcesnewsgroupsinfomagicoctober1994disk2.iso / misc / volume8 / elk / part05 < prev    next >
Text File  |  1989-09-23  |  59KB  |  2,376 lines
  1. Newsgroups: comp.sources.misc
  2. From: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc)
  3. Subject: v08i053: Elk (Extension Language Toolkit) part 05 of 14
  4. Reply-To: net@tub.UUCP (Oliver Laumann)
  5.  
  6. Posting-number: Volume 8, Issue 53
  7. Submitted-by: net@tub.UUCP (Oliver Laumann)
  8. Archive-name: elk/part05
  9.  
  10. [Let this be a lesson to submitters:  this was submitted as uuencoded,
  11. compressed files.  I lost the source information while unpacking it; this
  12. is the best approximation I could come up with.  ++bsa]
  13.  
  14. #! /bin/sh
  15. # This is a shell archive.  Remove anything before this line, then unpack
  16. # it by saving it into a file and typing "sh file".  To overwrite existing
  17. # files, type "sh file -c".  You can also feed this as standard input via
  18. # unshar, or by typing "sh <file", e.g..  If this archive is complete, you
  19. # will see the following message at the end:
  20. #        "End of archive 5 (of 14)."
  21. # Contents:  src/string.c src/vector.c src/cont.c src/print.c
  22. #   src/read.c src/io.c src/load.c src/auto.c src/alloca.s.vax
  23. # Wrapped by net@tub on Sun Sep 17 17:32:24 1989
  24. PATH=/bin:/usr/bin:/usr/ucb ; export PATH
  25. if test -f src/string.c -a "${1}" != "-c" ; then 
  26.   echo shar: Will not over-write existing file \"src/string.c\"
  27. else
  28. echo shar: Extracting \"src/string.c\" \(6826 characters\)
  29. sed "s/^X//" >src/string.c <<'END_OF_src/string.c'
  30. X/* Strings
  31. X */
  32. X
  33. X#include <ctype.h>
  34. X
  35. X#include "scheme.h"
  36. X
  37. Xchar Char_Map[256];
  38. X
  39. XInit_String () {
  40. X    register i;
  41. X
  42. X    for (i = 0; i < 256; i++)
  43. X    Char_Map[i] = i;
  44. X    for (i = 'A'; i <= 'Z'; i++)
  45. X    Char_Map[i] = tolower (i);
  46. X}
  47. X
  48. XObject Make_String (s, len) char *s; {
  49. X    Object str;
  50. X    register char *p;
  51. X
  52. X    p = Get_Bytes (len + sizeof (struct S_String) - 1);
  53. X    SET(str, T_String, (struct S_String *)p);
  54. X    STRING(str)->tag = Null;
  55. X    STRING(str)->size = len;
  56. X    if (s)
  57. X    bcopy (s, STRING(str)->data, len);
  58. X    return str;
  59. X}
  60. X
  61. XObject P_Stringp (s) Object s; {
  62. X    return TYPE(s) == T_String ? True : False;
  63. X}
  64. X
  65. XObject P_Make_String (argc, argv) Object *argv; {
  66. X    register len, c = ' ';
  67. X    Object str;
  68. X    register char *p;
  69. X
  70. X    if ((len = Get_Integer (argv[0])) < 0)
  71. X    Range_Error (argv[0]);
  72. X    if (argc == 2) {
  73. X    Check_Type (argv[1], T_Character);
  74. X    c = CHAR(argv[1]);
  75. X    }
  76. X    str = Make_String ((char *)0, len);
  77. X    for (p = STRING(str)->data; len; len--) *p++ = c;
  78. X    return str;
  79. X}
  80. X
  81. XObject P_String (argc, argv) Object *argv; {
  82. X    Object str;
  83. X    register i;
  84. X
  85. X    str = Make_String ((char *)0, argc);
  86. X    for (i = 0; i < argc; i++) {
  87. X    Check_Type (argv[i], T_Character);
  88. X    STRING(str)->data[i] = CHAR(argv[i]);
  89. X    }
  90. X    return str;
  91. X}
  92. X
  93. XObject P_String_To_Number (s) Object s; {
  94. X    Object ret;
  95. X    register char *b;
  96. X    register struct S_String *p;
  97. X
  98. X    Check_Type (s, T_String);
  99. X    p = STRING(s);
  100. X    if (stksize () + p->size > maxstack) goto err;
  101. X    b = alloca (p->size+1);
  102. X    bcopy (p->data, b, p->size);
  103. X    b[p->size] = '\0';
  104. X    ret = Read_Number_Maybe (b);
  105. X    if (Nullp (ret))
  106. Xerr:
  107. X    Primitive_Error ("argument does not represent a number");
  108. X    return ret;
  109. X}
  110. X
  111. XObject P_String_Length (s) Object s; {
  112. X    Check_Type (s, T_String);
  113. X    return Make_Integer (STRING(s)->size);
  114. X}
  115. X
  116. XObject P_String_Ref (s, n) Object s, n; {
  117. X    Check_Type (s, T_String);
  118. X    return Make_Char (STRING(s)->data[Get_Index (n, s)]);
  119. X}
  120. X
  121. XObject P_String_Set (s, n, new) Object s, n, new; {
  122. X    register i, old;
  123. X
  124. X    Check_Type (s, T_String);
  125. X    Check_Type (new, T_Character);
  126. X    old = STRING(s)->data[i = Get_Index (n, s)];
  127. X    STRING(s)->data[i] = CHAR(new);
  128. X    return Make_Char (old);
  129. X}
  130. X
  131. XObject P_Substring (s, a, b) Object s, a, b; {
  132. X    register i, j;
  133. X
  134. X    Check_Type (s, T_String);
  135. X    if ((i = Get_Integer (a)) < 0 || i > STRING(s)->size)
  136. X    Range_Error (a);
  137. X    if ((j = Get_Integer (b)) < 0 || j > STRING(s)->size)
  138. X    Range_Error (b);
  139. X    if (i > j)
  140. X    Primitive_Error ("`end' less than `start'");
  141. X    return Make_String (&STRING(s)->data[i], j-i);
  142. X}
  143. X
  144. XObject P_String_Copy (s) Object s; {
  145. X    Check_Type (s, T_String);
  146. X    return Make_String (STRING(s)->data, STRING(s)->size);
  147. X}
  148. X
  149. XObject P_String_Append (argc, argv) Object *argv; {
  150. X    register i, len;
  151. X    Object s, str;
  152. X
  153. X    for (len = i = 0; i < argc; i++) {
  154. X    Check_Type (argv[i], T_String);
  155. X    len += STRING(argv[i])->size;
  156. X    }
  157. X    str = Make_String ((char *)0, len);
  158. X    for (len = i = 0; i < argc; i++) {
  159. X    s = argv[i];
  160. X    bcopy (STRING(s)->data, &STRING(str)->data[len], STRING(s)->size);
  161. X    len += STRING(s)->size;
  162. X    }
  163. X    return str;
  164. X}
  165. X
  166. XObject P_List_To_String (list) Object list; {
  167. X    Object str, len;
  168. X    register i;
  169. X    GC_Node;
  170. X
  171. X    GC_Link (list);
  172. X    len = P_Length (list);
  173. X    str = Make_String ((char *)0, FIXNUM(len));
  174. X    for (i = 0; i < FIXNUM(len); i++, list = Cdr (list)) {
  175. X    Check_Type (Car (list), T_Character);
  176. X    STRING(str)->data[i] = CHAR(Car (list));
  177. X    }
  178. X    GC_Unlink;
  179. X    return str;
  180. X}
  181. X
  182. XObject P_String_To_List (s) Object s; {
  183. X    register i;
  184. X    Object list, tail, cell;
  185. X    GC_Node3;
  186. X
  187. X    Check_Type (s, T_String);
  188. X    list = tail = Null;
  189. X    GC_Link3 (s, list, tail);
  190. X    for (i = 0; i < STRING(s)->size; i++, tail = cell) {
  191. X    cell = Cons (Make_Char (STRING(s)->data[i]), Null);
  192. X    if (Nullp (list))
  193. X        list = cell;
  194. X    else
  195. X        P_Setcdr (tail, cell);
  196. X    }
  197. X    GC_Unlink;
  198. X    return list;
  199. X}
  200. X
  201. XObject P_Substring_Fill (s, a, b, c) Object s, a, b, c; {
  202. X    register i, j;
  203. X
  204. X    Check_Type (s, T_String);
  205. X    Check_Type (c, T_Character);
  206. X    i = Get_Index (a, s);
  207. X    if ((j = Get_Integer (b)) < 0 || j > STRING(s)->size)
  208. X    Range_Error (b);
  209. X    if (i > j)
  210. X    Primitive_Error ("`end' less than `start'");
  211. X    while (i < j)
  212. X    STRING(s)->data[i++] = CHAR(c);
  213. X    return s;
  214. X}
  215. X
  216. XObject P_String_Fill (s, c) Object s, c; {
  217. X    Object ret;
  218. X    GC_Node2;
  219. X
  220. X    GC_Link2 (s, c);
  221. X    Check_Type (s, T_String);
  222. X    ret = P_Substring_Fill (s, Make_Integer (0), 
  223. X    Make_Integer (STRING(s)->size), c);
  224. X    GC_Unlink;
  225. X    return ret;
  226. X}
  227. X
  228. XObject General_Substringp (s1, s2, ci) Object s1, s2; register ci; {
  229. X    register n, l1, l2;
  230. X    register char *p1, *p2, *p3, *map;
  231. X
  232. X    Check_Type (s1, T_String);
  233. X    Check_Type (s2, T_String);
  234. X    l1 = STRING(s1)->size;
  235. X    l2 = STRING(s2)->size;
  236. X    map = Char_Map;
  237. X    for (p2 = STRING(s2)->data; l2 >= l1; p2++, l2--) {
  238. X    for (p1 = STRING(s1)->data, p3 = p2, n = l1; n; n--, p1++, p3++) {
  239. X        if (ci) {
  240. X        if (map[*p1] != map[*p3]) goto fail;
  241. X        } else
  242. X        if (*p1 != *p3) goto fail;
  243. X    }
  244. X    return Make_Integer (STRING(s2)->size - l2);
  245. Xfail:   ;
  246. X    }
  247. X    return False;
  248. X}
  249. X
  250. XObject P_Substringp (s1, s2) Object s1, s2; {
  251. X    return General_Substringp (s1, s2, 0);
  252. X}
  253. X
  254. XObject P_CI_Substringp (s1, s2) Object s1, s2; {
  255. X    return General_Substringp (s1, s2, 1);
  256. X}
  257. X
  258. XGeneral_Strcmp (s1, s2, ci) Object s1, s2; register ci; {
  259. X    register n, l1, l2;
  260. X    register char *p1, *p2, *map;
  261. X
  262. X    Check_Type (s1, T_String);
  263. X    Check_Type (s2, T_String);
  264. X    l1 = STRING(s1)->size; l2 = STRING(s2)->size;
  265. X    n = l1 > l2 ? l2 : l1;
  266. X    p1 = STRING(s1)->data; p2 = STRING(s2)->data;
  267. X    for (map = Char_Map; --n >= 0; p1++, p2++) {
  268. X    if (ci) {
  269. X        if (map[*p1] != map[*p2]) break;
  270. X    } else
  271. X        if (*p1 != *p2) break;
  272. X    }
  273. X    if (n < 0)
  274. X    return l1 - l2;
  275. X    return *p1 - *p2;
  276. X}
  277. X
  278. XObject P_Str_Eq (s1, s2) Object s1, s2; {
  279. X    return General_Strcmp (s1, s2, 0) ? False : True;
  280. X}
  281. X
  282. XObject P_Str_Less (s1, s2) Object s1, s2; {
  283. X    return General_Strcmp (s1, s2, 0) < 0 ? True : False;
  284. X}
  285. X
  286. XObject P_Str_Greater (s1, s2) Object s1, s2; {
  287. X    return General_Strcmp (s1, s2, 0) > 0 ? True : False;
  288. X}
  289. X
  290. XObject P_Str_Eq_Less (s1, s2) Object s1, s2; {
  291. X    return General_Strcmp (s1, s2, 0) <= 0 ? True : False;
  292. X}
  293. X
  294. XObject P_Str_Eq_Greater (s1, s2) Object s1, s2; {
  295. X    return General_Strcmp (s1, s2, 0) >= 0 ? True : False;
  296. X}
  297. X
  298. XObject P_Str_CI_Eq (s1, s2) Object s1, s2; {
  299. X    return General_Strcmp (s1, s2, 1) ? False : True;
  300. X}
  301. X
  302. XObject P_Str_CI_Less (s1, s2) Object s1, s2; {
  303. X    return General_Strcmp (s1, s2, 1) < 0 ? True : False;
  304. X}
  305. X
  306. XObject P_Str_CI_Greater (s1, s2) Object s1, s2; {
  307. X    return General_Strcmp (s1, s2, 1) > 0 ? True : False;
  308. X}
  309. X
  310. XObject P_Str_CI_Eq_Less (s1, s2) Object s1, s2; {
  311. X    return General_Strcmp (s1, s2, 1) <= 0 ? True : False;
  312. X}
  313. X
  314. XObject P_Str_CI_Eq_Greater (s1, s2) Object s1, s2; {
  315. X    return General_Strcmp (s1, s2, 1) >= 0 ? True : False;
  316. X}
  317. END_OF_src/string.c
  318. if test 6826 -ne `wc -c <src/string.c`; then
  319.     echo shar: \"src/string.c\" unpacked with wrong size!
  320. fi
  321. # end of overwriting check
  322. fi
  323. if test -f src/vector.c -a "${1}" != "-c" ; then 
  324.   echo shar: Will not over-write existing file \"src/vector.c\"
  325. else
  326. echo shar: Extracting \"src/vector.c\" \(2773 characters\)
  327. sed "s/^X//" >src/vector.c <<'END_OF_src/vector.c'
  328. X/* Vectors
  329. X */
  330. X
  331. X#include "scheme.h"
  332. X
  333. XObject Make_Vector (len, fill) Object fill; {
  334. X    Object vec;
  335. X    register char *p;
  336. X    register Object *op;
  337. X    GC_Node;
  338. X    
  339. X    GC_Link (fill);
  340. X    p = Get_Bytes ((len-1) * sizeof (Object) + sizeof (struct S_Vector));
  341. X    SET(vec, T_Vector, (struct S_Vector *)p);
  342. X    VECTOR(vec)->tag = Null;
  343. X    VECTOR(vec)->size = len;
  344. X    for (op = VECTOR(vec)->data; len--; op++)
  345. X    *op = fill;
  346. X    GC_Unlink;
  347. X    return vec;
  348. X}
  349. X
  350. XObject P_Make_Vector (argc, argv) Object *argv; {
  351. X    register len;
  352. X
  353. X    if ((len = Get_Integer (argv[0])) < 0)
  354. X    Range_Error (argv[0]);
  355. X    return Make_Vector (len, argc == 1 ? Null : argv[1]);
  356. X}
  357. X
  358. XObject P_Vector (argc, argv) Object *argv; {
  359. X    Object vec;
  360. X    register i;
  361. X
  362. X    vec = Make_Vector (argc, Null);
  363. X    for (i = 0; i < argc; i++)
  364. X    VECTOR(vec)->data[i] = *argv++;
  365. X    return vec;
  366. X}
  367. X
  368. XObject P_Vectorp (x) Object x; {
  369. X    return TYPE(x) == T_Vector ? True : False;
  370. X}
  371. X
  372. XObject P_Vector_Length (x) Object x; {
  373. X    Check_Type (x, T_Vector);
  374. X    return Make_Integer (VECTOR(x)->size);
  375. X}
  376. X
  377. XObject P_Vector_Ref (vec, n) Object vec, n; {
  378. X    Check_Type (vec, T_Vector);
  379. X    return VECTOR(vec)->data[Get_Index (n, vec)];
  380. X}
  381. X
  382. XObject P_Vector_Set (vec, n, new) Object vec, n, new; {
  383. X    Object old;
  384. X    register i;
  385. X
  386. X    Check_Type (vec, T_Vector);
  387. X    old = VECTOR(vec)->data[i = Get_Index (n, vec)];
  388. X    VECTOR(vec)->data[i] = new;
  389. X    return old;
  390. X}
  391. X
  392. X/* We cannot simply call P_List with vec->size and vec->data here,
  393. X * because the latter can change during GC.  (Bletch!)
  394. X */
  395. XObject P_Vector_To_List (vec) Object vec; {
  396. X    register i;
  397. X    Object list, tail, cell;
  398. X    GC_Node3;
  399. X
  400. X    Check_Type (vec, T_Vector);
  401. X    list = tail = Null;
  402. X    GC_Link3 (vec, list, tail);
  403. X    for (i = 0; i < VECTOR(vec)->size; i++, tail = cell) {
  404. X    cell = Cons (VECTOR(vec)->data[i], Null);
  405. X    if (Nullp (list))
  406. X        list = cell;
  407. X    else
  408. X        P_Setcdr (tail, cell);
  409. X    }
  410. X    GC_Unlink;
  411. X    return list;
  412. X}
  413. X
  414. XObject P_List_To_Vector (list) Object list; {
  415. X    Object vec, len;
  416. X    register i;
  417. X    GC_Node;
  418. X
  419. X    GC_Link (list);
  420. X    len = P_Length (list);
  421. X    vec = Make_Vector (FIXNUM(len), Null);
  422. X    for (i = 0; i < FIXNUM(len); i++, list = Cdr (list))
  423. X    VECTOR(vec)->data[i] = Car (list);
  424. X    GC_Unlink;
  425. X    return vec;
  426. X}
  427. X
  428. XObject P_Vector_Fill (vec, fill) Object vec, fill; {
  429. X    register i;
  430. X
  431. X    Check_Type (vec, T_Vector);
  432. X    for (i = 0; i < VECTOR(vec)->size; i++)
  433. X    VECTOR(vec)->data[i] = fill;
  434. X    return vec;
  435. X}
  436. X
  437. XObject P_Vector_Copy (vec) Object vec; {
  438. X    Object new;
  439. X    GC_Node;
  440. X
  441. X    Check_Type (vec, T_Vector);
  442. X    GC_Link (vec);
  443. X    new = Make_Vector (VECTOR(vec)->size, Null);
  444. X    bcopy ((char *)POINTER(vec), (char *)POINTER(new),
  445. X    (VECTOR(vec)->size-1) * sizeof (Object) + sizeof (struct S_Vector));
  446. X    GC_Unlink;
  447. X    return new;
  448. X}
  449. END_OF_src/vector.c
  450. if test 2773 -ne `wc -c <src/vector.c`; then
  451.     echo shar: \"src/vector.c\" unpacked with wrong size!
  452. fi
  453. # end of overwriting check
  454. fi
  455. if test -f src/cont.c -a "${1}" != "-c" ; then 
  456.   echo shar: Will not over-write existing file \"src/cont.c\"
  457. else
  458. echo shar: Extracting \"src/cont.c\" \(3090 characters\)
  459. sed "s/^X//" >src/cont.c <<'END_OF_src/cont.c'
  460. X/* Control points, call-with-current-continuation, dynamic-wind
  461. X */
  462. X
  463. X#include <signal.h>
  464. X
  465. X#include "scheme.h"
  466. X
  467. XWIND *First_Wind, *Last_Wind;
  468. X
  469. XObject P_Control_Pointp (x) Object x; {
  470. X    return TYPE(x) == T_Control_Point ? True : False;
  471. X}
  472. X
  473. XObject Make_Control_Point (size) {
  474. X    Object control;
  475. X    register struct S_Control *cp;
  476. X    register char *p;
  477. X
  478. X    p = Get_Bytes (size + sizeof (struct S_Control) - 1);
  479. X    cp = (struct S_Control *)p;
  480. X    SET(control, T_Control_Point, cp);
  481. X    cp->env = The_Environment;
  482. X    cp->gclist = GC_List;
  483. X    cp->firstwind = First_Wind;
  484. X    cp->lastwind = Last_Wind;
  485. X    cp->tailcall = Tail_Call;
  486. X    cp->size = size;
  487. X    return control;
  488. X}
  489. X
  490. XObject P_Call_CC (proc) Object proc; {
  491. X    int size;
  492. X    Object control, ret;
  493. X    GC_Node;
  494. X
  495. X    Check_Procedure (proc);
  496. X    GC_Link (proc);
  497. X    size = stksize ();
  498. X    control = Make_Control_Point (size);
  499. X    SETFAST(ret,saveenv (CONTROL(control)->stack));
  500. X    if (TYPE(ret) != T_Special) {
  501. X    Enable_Interrupts;
  502. X    return ret;
  503. X    }
  504. X    control = Cons (control, Null);
  505. X    ret = Funcall (proc, control, 0);
  506. X    GC_Unlink;
  507. X    return ret;
  508. X}
  509. X
  510. XFuncall_Control_Point (control, argl, eval) Object control, argl; {
  511. X    Object val, len;
  512. X    register struct S_Control *cp;
  513. X    register WIND *wp, *p;
  514. X    register delta;
  515. X    GC_Node3;
  516. X
  517. X    val = Null;
  518. X    GC_Link3 (argl, control, val);
  519. X    len = P_Length (argl);
  520. X    if (FIXNUM(len) != 1)
  521. X    Primitive_Error ("control point expects one argument");
  522. X    val = Car (argl);
  523. X    if (eval)
  524. X    val = Eval (val);
  525. X    for (wp = Last_Wind; wp; wp = wp->prev)
  526. X    Do_Wind (wp->out);
  527. X    delta = *(int *)(CONTROL(control)->stack);
  528. X    for (wp = CONTROL(control)->firstwind; wp; wp = p->next) {
  529. X    p = (WIND *)NORM(wp);
  530. X    Do_Wind (p->in);
  531. X    }
  532. X    GC_Unlink;
  533. X    cp = CONTROL(control);
  534. X    Switch_Environment (cp->env);
  535. X    GC_List = cp->gclist;
  536. X    First_Wind = cp->firstwind;
  537. X    Last_Wind = cp->lastwind;
  538. X    Tail_Call = cp->tailcall;
  539. X    jmpenv (cp->stack, val);
  540. X    /*NOTREACHED*/
  541. X}
  542. X
  543. XDo_Wind (w) Object w; {
  544. X    Object b, sym, val;
  545. X
  546. X    if (TYPE(w) == T_Pair) {
  547. X    b = Lookup_Symbol (Car (w), 0);
  548. X    if (Nullp (b))
  549. X        Panic ("fluid-let2");
  550. X    sym = Car (b);
  551. X    val = Cdr (w);
  552. X    Cdr (b) = val;
  553. X    SYMBOL(sym)->value = val;
  554. X    } else {
  555. X    (void)Funcall (w, Null, 0);
  556. X    }
  557. X}
  558. X
  559. XAdd_Wind (w, in, out) register WIND *w; Object in, out; {
  560. X    w->in = in;
  561. X    w->out = out;
  562. X    w->next = 0;
  563. X    if (First_Wind == 0)
  564. X    First_Wind = w;
  565. X    else
  566. X    Last_Wind->next = w;
  567. X    w->prev = Last_Wind;
  568. X    Last_Wind = w;
  569. X}
  570. X
  571. XObject P_Dynamic_Wind (in, body, out) Object in, body, out; {
  572. X    WIND w, *first = First_Wind;
  573. X    Object ret;
  574. X    GC_Node3;
  575. X
  576. X    Check_Procedure (in);
  577. X    Check_Procedure (body);
  578. X    Check_Procedure (out);
  579. X    ret = Null;
  580. X    GC_Link3 (body, out, ret);
  581. X    Add_Wind (&w, in, out);
  582. X    (void)Funcall (in, Null, 0);
  583. X    ret = Funcall (body, Null, 0);
  584. X    (void)Funcall (out, Null, 0);
  585. X    if (Last_Wind = w.prev)
  586. X    Last_Wind->next = 0;
  587. X    First_Wind = first;
  588. X    GC_Unlink;
  589. X    return ret;
  590. X}
  591. X
  592. XObject P_Control_Point_Env (c) Object c; {
  593. X    Check_Type (c, T_Control_Point);
  594. X    return CONTROL(c)->env;
  595. X}
  596. END_OF_src/cont.c
  597. if test 3090 -ne `wc -c <src/cont.c`; then
  598.     echo shar: \"src/cont.c\" unpacked with wrong size!
  599. fi
  600. # end of overwriting check
  601. fi
  602. if test -f src/print.c -a "${1}" != "-c" ; then 
  603.   echo shar: Will not over-write existing file \"src/print.c\"
  604. else
  605. echo shar: Extracting \"src/print.c\" \(12446 characters\)
  606. sed "s/^X//" >src/print.c <<'END_OF_src/print.c'
  607. X/* Output functions
  608. X */
  609. X
  610. X#include <ctype.h>
  611. X#include <varargs.h>
  612. X#include <sys/ioctl.h>
  613. X
  614. X#include "scheme.h"
  615. X
  616. Xint Saved_Errno;
  617. X
  618. Xstatic Object V_Print_Depth, V_Print_Length;
  619. X
  620. XInit_Print () {
  621. X    Define_Variable (&V_Print_Depth, "print-depth",
  622. X    Make_Fixnum (DEF_PRINT_DEPTH));
  623. X    Define_Variable (&V_Print_Length, "print-length",
  624. X    Make_Fixnum (DEF_PRINT_LEN));
  625. X}
  626. X
  627. XPrint_Length () {
  628. X    Object pl;
  629. X
  630. X    pl = Val (V_Print_Length);
  631. X    return TYPE(pl) == T_Fixnum ? FIXNUM(pl) : DEF_PRINT_LEN;
  632. X}
  633. X
  634. XPrint_Depth () {
  635. X    Object pd;
  636. X
  637. X    pd = Val (V_Print_Depth);
  638. X    return TYPE(pd) == T_Fixnum ? FIXNUM(pd) : DEF_PRINT_DEPTH;
  639. X}
  640. X
  641. XPrint_Char (port, c) Object port; register c; {
  642. X    char buf[1];
  643. X
  644. X    if (PORT(port)->flags & P_STRING) {
  645. X    buf[0] = c;
  646. X    Print_String (port, buf, 1);
  647. X    } else {
  648. X    if (putc (c, PORT(port)->file) == EOF)  {
  649. X        Saved_Errno = errno;   /* errno valid here? */
  650. X        Primitive_Error ("write error on ~s: ~E", port);
  651. X    }
  652. X    }
  653. X}
  654. X
  655. XPrint_String (port, buf, len) Object port; register char *buf; register len; {
  656. X    register n;
  657. X    register struct S_Port *p;
  658. X    Object new;
  659. X    GC_Node;
  660. X
  661. X    p = PORT(port);
  662. X    n = STRING(p->name)->size - p->ptr;
  663. X    if (n < len) {
  664. X    GC_Link (port);
  665. X    n = len - n;
  666. X    if (n < STRING_GROW_SIZE)
  667. X        n = STRING_GROW_SIZE;
  668. X    new = Make_String ((char *)0, STRING(p->name)->size + n);
  669. X    p = PORT(port);
  670. X    GC_Unlink;
  671. X    bcopy (STRING(p->name)->data, STRING(new)->data, p->ptr);
  672. X    p->name = new;
  673. X    }
  674. X    bcopy (buf, STRING(p->name)->data + p->ptr, len);
  675. X    p->ptr += len;
  676. X}
  677. X
  678. X#ifndef VPRINTF
  679. Xvfprintf (f, fmt, ap) register FILE *f; register char *fmt; va_list ap; {
  680. X    _doprnt (fmt, ap, f);
  681. X}
  682. X
  683. Xvsprintf (s, fmt, ap) register char *s, *fmt; va_list ap; {
  684. X    FILE x;
  685. X    x._flag = _IOWRT|_IOSTRG;
  686. X    x._ptr = s;
  687. X    x._cnt = 1024;
  688. X    _doprnt (fmt, ap, &x);
  689. X    putc ('\0', &x);
  690. X}
  691. X#endif
  692. X
  693. X/*VARARGS0*/
  694. XPrintf (va_alist) va_dcl {
  695. X    va_list args;
  696. X    Object port;
  697. X    char *fmt;
  698. X    char buf[1024];
  699. X
  700. X    va_start (args);
  701. X    port = va_arg (args, Object);
  702. X    fmt = va_arg (args, char *);
  703. X    if (PORT(port)->flags & P_STRING) {
  704. X    vsprintf (buf, fmt, args);
  705. X    Print_String (port, buf, strlen (buf));
  706. X    } else {
  707. X    vfprintf (PORT(port)->file, fmt, args);
  708. X    if (ferror (PORT(port)->file)) {
  709. X        Saved_Errno = errno;   /* errno valid here? */
  710. X        Primitive_Error ("write error on ~s: ~E", port);
  711. X    }
  712. X    }
  713. X    va_end (args);
  714. X}
  715. X
  716. XObject General_Print (argc, argv, raw) Object *argv; {
  717. X    General_Print_Object (argv[0], argc == 2 ? argv[1] : Curr_Output_Port, raw);
  718. X    return Void;
  719. X}
  720. X
  721. XObject P_Write (argc, argv) Object *argv; {
  722. X    return General_Print (argc, argv, 0);
  723. X}
  724. X
  725. XObject P_Display (argc, argv) Object *argv; {
  726. X    return General_Print (argc, argv, 1);
  727. X}
  728. X
  729. XObject P_Write_Char (argc, argv) Object *argv; {
  730. X    Check_Type (argv[0], T_Character);
  731. X    return General_Print (argc, argv, 1);
  732. X}
  733. X
  734. X/*VARARGS1*/
  735. XObject P_Newline (argc, argv) Object *argv; {
  736. X    General_Print_Object (Newline, argc == 1 ? argv[0] : Curr_Output_Port, 1);
  737. X    return Void;
  738. X}
  739. X
  740. XObject P_Print (argc, argv) Object *argv; {
  741. X    Object port;
  742. X    GC_Node;
  743. X
  744. X    port = argc == 2 ? argv[1] : Curr_Output_Port;
  745. X    GC_Link (port);
  746. X    General_Print_Object (argv[0], port, 0);
  747. X    Print_Char (port, '\n');
  748. X    Flush_Output (port);
  749. X    GC_Unlink;
  750. X    return Void;
  751. X}
  752. X
  753. XObject P_Clear_Output_Port (argc, argv) Object *argv; {
  754. X    Discard_Output (argc == 1 ? argv[0] : Curr_Output_Port);
  755. X    return Void;
  756. X}
  757. X
  758. XDiscard_Output (port) Object port; {
  759. X    register FILE *f;
  760. X
  761. X    Check_Output_Port (port);
  762. X    if (PORT(port)->flags & P_STRING)
  763. X    return;
  764. X    f = PORT(port)->file;
  765. X    f->_cnt = 0;
  766. X    f->_ptr = f->_base;
  767. X#ifdef TIOCFLUSH
  768. X    (void)ioctl (fileno (f), TIOCFLUSH, (char *)0);
  769. X#endif
  770. X}
  771. X
  772. XObject P_Flush_Output_Port (argc, argv) Object *argv; {
  773. X    Flush_Output (argc == 1 ? argv[0] : Curr_Output_Port);
  774. X    return Void;
  775. X}
  776. X
  777. XFlush_Output (port) Object port; {
  778. X    Check_Output_Port (port);
  779. X    if (PORT(port)->flags & P_STRING)
  780. X    return;
  781. X    if (fflush (PORT(port)->file) == EOF) {
  782. X    Saved_Errno = errno;   /* errno valid here? */
  783. X    Primitive_Error ("write error on ~s: ~E", port);
  784. X    }
  785. X}
  786. X
  787. XObject P_Get_Output_String (port) Object port; {
  788. X    register struct S_Port *p;
  789. X    Object str;
  790. X    GC_Node;
  791. X
  792. X    Check_Output_Port (port);
  793. X    GC_Link (port);
  794. X    str = Make_String ((char *)0, PORT(port)->ptr);
  795. X    p = PORT(port);
  796. X    bcopy (STRING(p->name)->data, STRING(str)->data, p->ptr);
  797. X    p->ptr = 0;
  798. X    GC_Unlink;
  799. X    return str;
  800. X}
  801. X    
  802. XCheck_Output_Port (port) Object port; {
  803. X    Check_Type (port, T_Port);
  804. X    if (!(PORT(port)->flags & P_OPEN))
  805. X    Primitive_Error ("port has been closed: ~s", port);
  806. X    if (PORT(port)->flags & P_INPUT)
  807. X    Primitive_Error ("not an output port: ~s", port);
  808. X}
  809. X
  810. XGeneral_Print_Object (x, port, raw) Object x, port; {
  811. X    Check_Output_Port (port);
  812. X    Print_Object (x, port, raw, Print_Depth (), Print_Length ());
  813. X}
  814. X
  815. XPrint_Object (x, port, raw, depth, length) Object x, port;
  816. X    register raw, depth, length; {
  817. X    register t, c, str;
  818. X    GC_Node2;
  819. X
  820. X    GC_Link2 (port, x);
  821. X    t = TYPE(x);
  822. X    switch (t) {
  823. X    case T_Null:
  824. X    Printf (port, "()");
  825. X    break;
  826. X    case T_Fixnum:
  827. X    Printf (port, "%d", FIXNUM(x));
  828. X    break;
  829. X    case T_Bignum:
  830. X    Print_Bignum (port, x);
  831. X    break;
  832. X    case T_Flonum:
  833. X    Printf (port, "%.15g", FLONUM(x)->val);
  834. X    break;
  835. X    case T_Boolean:
  836. X    Printf (port, "#%c", FIXNUM(x) ? 't' : 'f');
  837. X    break;
  838. X    case T_Void:
  839. X    break;
  840. X    case T_Unbound:
  841. X    Printf (port, "#[unbound]");
  842. X    break;
  843. X    case T_Special:
  844. X    Printf (port, "#[special]");
  845. X    break;
  846. X    case T_Character:
  847. X    c = CHAR(x);
  848. X    if (raw)
  849. X        Print_Char (port, c);
  850. X    else
  851. X        Pr_Char (port, c);
  852. X    break;
  853. X    case T_Symbol:
  854. X    Pr_String (port, SYMBOL(x)->name, 1);
  855. X    break;
  856. X    case T_Pair:
  857. X    Pr_List (port, x, raw, depth, length);
  858. X    break;
  859. X    case T_Environment:
  860. X    Printf (port, "#[environment %u]", POINTER(x));
  861. X    break;
  862. X    case T_String:
  863. X    Pr_String (port, x, raw);
  864. X    break;
  865. X    case T_Vector:
  866. X    Pr_Vector (port, x, raw, depth, length);
  867. X    break;
  868. X    case T_Primitive:
  869. X    Printf (port, "#[primitive %s]", PRIM(x)->name);
  870. X    break;
  871. X    case T_Compound:
  872. X    if (Nullp (COMPOUND(x)->name)) {
  873. X        Printf (port, "#[compound %u]", POINTER(x));
  874. X    } else {
  875. X        Printf (port, "#[compound ");
  876. X        Print_Object (COMPOUND(x)->name, port, raw, depth, length);
  877. X        Print_Char (port, ']');
  878. X    }
  879. X    break;
  880. X    case T_Control_Point:
  881. X    Printf (port, "#[control-point %u]", POINTER(x));
  882. X    break;
  883. X    case T_Promise:
  884. X    Printf (port, "#[promise %u]", POINTER(x));
  885. X    break;
  886. X    case T_Port:
  887. X    str = PORT(x)->flags & P_STRING;
  888. X    Printf (port, "#[%s-%sput-port ", str ? "string" : "file",
  889. X        (PORT(x)->flags & P_INPUT) ? "in" : "out");
  890. X    if (str)
  891. X        Printf (port, "%u", POINTER(x));
  892. X    else
  893. X        Pr_String (port, PORT(x)->name, 0);
  894. X    Print_Char (port, ']');
  895. X    break;
  896. X    case T_End_Of_File:
  897. X    Printf (port, "#[end-of-file]");
  898. X    break;
  899. X    case T_Autoload:
  900. X    Printf (port, "#[autoload ");
  901. X    Print_Object (AUTOLOAD(x)->file, port, raw, depth, length);
  902. X    Print_Char (port, ']');
  903. X    break;
  904. X    case T_Macro:
  905. X    if (Nullp (MACRO(x)->name)) {
  906. X        Printf (port, "#[macro %u]", POINTER(x));
  907. X    } else {
  908. X        Printf (port, "#[macro ");
  909. X        Print_Object (MACRO(x)->name, port, raw, depth, length);
  910. X        Print_Char (port, ']');
  911. X    }
  912. X    break;
  913. X    case T_Broken_Heart:
  914. X    Printf (port, "!!broken-heart!!");
  915. X    break;
  916. X    default:
  917. X    if (t < 0 || t >= MAX_TYPE || !Types[t].name)
  918. X        Panic ("bad type in print");
  919. X    (*Types[t].print)(x, port, raw, depth, length);
  920. X    }
  921. X    GC_Unlink;
  922. X}
  923. X
  924. XPr_Char (port, c) Object port; register c; {
  925. X    register char *p = 0;
  926. X
  927. X    switch (c) {
  928. X    case ' ':
  929. X    p = "#\\space";
  930. X    break;
  931. X    case '\t':
  932. X    p = "#\\tab";
  933. X    break;
  934. X    case '\n':
  935. X    p = "#\\newline";
  936. X    break;
  937. X    case '\r':
  938. X    p = "#\\return";
  939. X    break;
  940. X    case '\f':
  941. X    p = "#\\formfeed";
  942. X    break;
  943. X    case '\b':
  944. X    p = "#\\backspace";
  945. X    break;
  946. X    default:
  947. X    if (c > ' ' && c < '\177')
  948. X        Printf (port, "#\\%c", c);
  949. X    else
  950. X        Printf (port, "#\\%03o", (unsigned char)c);
  951. X    }
  952. X    if (p) Printf (port, p);
  953. X}
  954. X
  955. XPr_List (port, list, raw, depth, length) Object port, list;
  956. X    register raw, depth, length; {
  957. X    Object tail;
  958. X    register len;
  959. X    register char *s = 0;
  960. X    GC_Node2;
  961. X
  962. X    if (depth <= 0) {
  963. X    Printf (port, "&");
  964. X    return;
  965. X    }
  966. X    GC_Link2 (port, list);
  967. X    if (!Nullp (list) && ((tail = Cdr (list)), TYPE(tail) == T_Pair)
  968. X              && ((tail = Cdr (tail)), Nullp (tail))) {
  969. X    tail = Car (list);
  970. X    if (EQ(tail, Sym_Quote))
  971. X        s = "'";
  972. X    else if (EQ(tail, Sym_Quasiquote))
  973. X        s = "`";
  974. X    else if (EQ(tail, Sym_Unquote))
  975. X        s = ",";
  976. X    else if (EQ(tail, Sym_Unquote_Splicing))
  977. X        s = ",@";
  978. X    if (s) {
  979. X        Printf (port, s);
  980. X        Print_Object (Car (Cdr (list)), port, raw, depth-1, length);
  981. X        GC_Unlink;
  982. X        return;
  983. X    }
  984. X    }
  985. X    Print_Char (port, '(');
  986. X    for (len = 0; !Nullp (list); len++, list = tail) {
  987. X    if (len >= length) {
  988. X        Printf (port, "...");
  989. X        break;
  990. X    }
  991. X    Print_Object (Car (list), port, raw, depth-1, length);
  992. X    tail = Cdr (list);
  993. X    if (!Nullp (tail)) {
  994. X        if (TYPE(tail) == T_Pair)
  995. X        Print_Char (port, ' ');
  996. X        else {
  997. X        Printf (port, " . ");
  998. X        Print_Object (tail, port, raw, depth-1, length);
  999. X        break;
  1000. X        }
  1001. X    }
  1002. X    }
  1003. X    Print_Char (port, ')');
  1004. X    GC_Unlink;
  1005. X}
  1006. X
  1007. XPr_Vector (port, vec, raw, depth, length) Object port, vec;
  1008. X    register raw, depth, length; {
  1009. X    register i, j;
  1010. X    GC_Node2;
  1011. X
  1012. X    if (depth <= 0) {
  1013. X    Printf (port, "&");
  1014. X    return;
  1015. X    }
  1016. X    GC_Link2 (port, vec);
  1017. X    Printf (port, "#(");
  1018. X    for (i = 0, j = VECTOR(vec)->size; i < j; i++) {
  1019. X    if (i) Print_Char (port, ' ');
  1020. X    if (i >= length) {
  1021. X        Printf (port, "...");
  1022. X        break;
  1023. X    }
  1024. X    Print_Object (VECTOR(vec)->data[i], port, raw, depth-1, length);
  1025. X    }
  1026. X    Print_Char (port, ')');
  1027. X    GC_Unlink;
  1028. X}
  1029. X
  1030. XPr_String (port, str, raw) Object port, str; {
  1031. X    register char *p = STRING(str)->data;
  1032. X    register c, i, len = STRING(str)->size;
  1033. X    GC_Node2;
  1034. X
  1035. X    if (raw) {
  1036. X    if (PORT(port)->flags & P_STRING) {
  1037. X        Print_String (port, p, len);
  1038. X    } else {
  1039. X        if (fwrite (p, 1, len, PORT(port)->file) < len) {
  1040. X        Saved_Errno = errno;   /* errno valid here? */
  1041. X        Primitive_Error ("write error on ~s: ~E", port);
  1042. X        }
  1043. X    }
  1044. X    return;
  1045. X    }
  1046. X    GC_Link2 (port, str);
  1047. X    Print_Char (port, '"');
  1048. X    for (i = 0; i < STRING(str)->size; i++) {
  1049. X    c = STRING(str)->data[i];
  1050. X    if (c == '\\' || c == '"')
  1051. X        Print_Char (port, '\\');
  1052. X    if (c < ' ' || c >= '\177')
  1053. X        Print_Special (port, c);
  1054. X    else
  1055. X    Print_Char (port, c);
  1056. X    }
  1057. X    Print_Char (port, '"');
  1058. X    GC_Unlink;
  1059. X}
  1060. X
  1061. XPrint_Special (port, c) Object port; register c; {
  1062. X    register char *fmt = "\\%c";
  1063. X
  1064. X    switch (c) {
  1065. X    case '\b': c = 'b'; break;
  1066. X    case '\t': c = 't'; break;
  1067. X    case '\r': c = 'r'; break;
  1068. X    case '\n': c = 'n'; break;
  1069. X    default:
  1070. X    fmt = "\\%03o";
  1071. X    }
  1072. X    Printf (port, fmt, (unsigned char)c);
  1073. X}
  1074. X
  1075. XObject P_Format (argc, argv) Object *argv; {
  1076. X    Object port, str;
  1077. X    register stringret = 0;
  1078. X    GC_Node;
  1079. X
  1080. X    port = argv[0];
  1081. X    if (TYPE(port) == T_Boolean) {
  1082. X    if (Truep (port)) {
  1083. X        port = Curr_Output_Port;
  1084. X    } else {
  1085. X        stringret++;
  1086. X        port = P_Open_Output_String ();
  1087. X    }
  1088. X    } else if (TYPE(port) == T_Port) {
  1089. X    Check_Output_Port (port);
  1090. X    } else Wrong_Type_Combination (port, "port or #t or #f");
  1091. X    str = argv[1];
  1092. X    Check_Type (str, T_String);
  1093. X    GC_Link (port);
  1094. X    Format (port, STRING(str)->data, STRING(str)->size, argc-2, argv+2);
  1095. X    GC_Unlink;
  1096. X    return stringret ? P_Get_Output_String (port) : Void;
  1097. X}
  1098. X
  1099. XFormat (port, p, len, argc, argv) Object port; register char *p;
  1100. X    register len; Object *argv; {
  1101. X    register char *s, *ep;
  1102. X    register c;
  1103. X    char buf[256];
  1104. X    extern sys_nerr;
  1105. X    extern char *sys_errlist[];
  1106. X    GC_Node;
  1107. X
  1108. X    GC_Link (port);
  1109. X    for (ep = p + len; p < ep; p++) {
  1110. X    if (*p == '~') {
  1111. X        if (++p == ep) break;
  1112. X        if ((c = *p) == '~') {
  1113. X        Print_Char (port, c);
  1114. X        } else if (c == '%') {
  1115. X        Print_Char (port, '\n');
  1116. X        } else if (c == 'e' || c == 'E') {
  1117. X        if (Saved_Errno > 0 && Saved_Errno < sys_nerr) {
  1118. X            s = sys_errlist[Saved_Errno];
  1119. X            sprintf (buf, "%c%s", isupper (*s) ? tolower (*s) :
  1120. X            *s, s+1);
  1121. X        } else {
  1122. X            sprintf (buf, "error %d", Saved_Errno);
  1123. X        }
  1124. X        Print_Object (Make_String (buf, strlen (buf)), port,
  1125. X            c == 'E', 0, 0);
  1126. X        } else {
  1127. X        if (--argc < 0)
  1128. X            Primitive_Error ("too few arguments");
  1129. X        if (c == 's' || c == 'a') {
  1130. X            Print_Object (*argv, port, c == 'a', Print_Depth (),
  1131. X            Print_Length ());
  1132. X            argv++;
  1133. X        } else if (c == 'c') {
  1134. X            Check_Type (*argv, T_Character);
  1135. X            Print_Char (port, CHAR(*argv));
  1136. X            argv++;
  1137. X        } else Print_Char (port, c);
  1138. X        }
  1139. X    } else {
  1140. X        Print_Char (port, *p);
  1141. X    }
  1142. X    }
  1143. X    GC_Unlink;
  1144. X}
  1145. END_OF_src/print.c
  1146. if test 12446 -ne `wc -c <src/print.c`; then
  1147.     echo shar: \"src/print.c\" unpacked with wrong size!
  1148. fi
  1149. # end of overwriting check
  1150. fi
  1151. if test -f src/read.c -a "${1}" != "-c" ; then 
  1152.   echo shar: Will not over-write existing file \"src/read.c\"
  1153. else
  1154. echo shar: Extracting \"src/read.c\" \(12649 characters\)
  1155. sed "s/^X//" >src/read.c <<'END_OF_src/read.c'
  1156. X/* Input Functions
  1157. X */
  1158. X
  1159. X#include <ctype.h>
  1160. X#include <math.h>       /* atof */
  1161. X#include <signal.h>
  1162. X
  1163. X#include "scheme.h"
  1164. X
  1165. X#ifdef TERMIO
  1166. X#  include <termio.h>
  1167. X#else
  1168. X#  include <sys/ioctl.h>
  1169. X#endif
  1170. X
  1171. Xextern char *index();
  1172. X
  1173. XObject Sym_Quote,
  1174. X       Sym_Quasiquote,
  1175. X       Sym_Unquote,
  1176. X       Sym_Unquote_Splicing;
  1177. X
  1178. Xstatic FILE *Last_File;
  1179. X
  1180. X#define GETC    (str ? String_Getc (port) : getc (f))
  1181. X#define UNGETC  {if (str) String_Ungetc (port,c); else (void)ungetc (c,f);}
  1182. X
  1183. X#define Tweak_Stream(f) {if (!str && (feof (f) || ferror (f))) clearerr (f);}
  1184. X
  1185. X#define Octal(c) ((c) >= '0' && (c) <= '7')
  1186. X
  1187. XObject General_Read(), Read_Sequence(), Read_Atom(), Read_Special();
  1188. XObject Read_String(), Read_Sharp();
  1189. X
  1190. XInit_Read () {
  1191. X    Define_Symbol (&Sym_Quote, "quote");
  1192. X    Define_Symbol (&Sym_Quasiquote, "quasiquote");
  1193. X    Define_Symbol (&Sym_Unquote, "unquote");
  1194. X    Define_Symbol (&Sym_Unquote_Splicing, "unquote-splicing");
  1195. X}
  1196. X
  1197. XObject P_Exit (argc, argv) Object *argv; {
  1198. X    exit (argc == 0 ? 0 : Get_Integer (argv[0]));
  1199. X    /*NOTREACHED*/
  1200. X}
  1201. X
  1202. XString_Getc (port) Object port; {
  1203. X    register struct S_Port *p;
  1204. X    register struct S_String *s;
  1205. X
  1206. X    p = PORT(port);
  1207. X    if (p->flags & P_UNREAD) {
  1208. X    p->flags &= ~P_UNREAD;
  1209. X    return p->unread;
  1210. X    }
  1211. X    s = STRING(p->name);
  1212. X    return p->ptr >= s->size ? EOF : s->data[p->ptr++];
  1213. X}
  1214. X
  1215. XString_Ungetc (port, c) Object port; register c; {
  1216. X    PORT(port)->flags |= P_UNREAD;
  1217. X    PORT(port)->unread = c;
  1218. X}
  1219. X
  1220. XCheck_Input_Port (port) Object port; {
  1221. X    Check_Type (port, T_Port);
  1222. X    if (!(PORT(port)->flags & P_OPEN))
  1223. X    Primitive_Error ("port has been closed: ~s", port);
  1224. X    if (!(PORT(port)->flags & P_INPUT))
  1225. X    Primitive_Error ("not an input port: ~s", port);
  1226. X}
  1227. X
  1228. XObject P_Clear_Input_Port (argc, argv) Object *argv; {
  1229. X    Discard_Input (argc == 1 ? argv[0] : Curr_Input_Port);
  1230. X    return Void;
  1231. X}
  1232. X
  1233. XDiscard_Input (port) Object port; {
  1234. X    register FILE *f;
  1235. X
  1236. X    Check_Input_Port (port);
  1237. X    if (PORT(port)->flags & P_STRING)
  1238. X    return;
  1239. X    f = PORT(port)->file;
  1240. X    f->_cnt = 0;
  1241. X    f->_ptr = f->_base;
  1242. X}
  1243. X
  1244. X/* NOTE: dumps core on ISI 4.2BSD when called on an input file port that
  1245. X * has not yet been read from.
  1246. X */
  1247. XObject P_Unread_Char (argc, argv) Object *argv; {
  1248. X    Object port, ch;
  1249. X    register struct S_Port *p;
  1250. X
  1251. X    ch = argv[0];
  1252. X    Check_Type (ch, T_Character);
  1253. X    port = argc == 2 ? argv[1] : Curr_Input_Port;
  1254. X    Check_Input_Port (port);
  1255. X    p = PORT(port);
  1256. X    if (p->flags & P_STRING) {
  1257. X    if (p->flags & P_UNREAD)
  1258. X        Primitive_Error ("cannot push back more than one char");
  1259. X    String_Ungetc (port, CHAR(ch));    
  1260. X    } else {
  1261. X    if (ungetc (CHAR(ch), p->file) == EOF)
  1262. X        Primitive_Error ("failed to push back char");
  1263. X    }
  1264. X    return ch;
  1265. X}
  1266. X
  1267. XTemp_Intr_Handler () {
  1268. X    Immediate_Mode (Last_File, 0);
  1269. X    (void)signal (SIGINT, Intr_Handler);
  1270. X    Intr_Handler ();
  1271. X}
  1272. X
  1273. XObject P_Read_Char (argc, argv) Object *argv; {
  1274. X    Object port;
  1275. X    register FILE *f;
  1276. X    register c, str, flags;
  1277. X
  1278. X    port = argc == 1 ? argv[0] : Curr_Input_Port;
  1279. X    Check_Input_Port (port);
  1280. X    f = PORT(port)->file;
  1281. X    flags = PORT(port)->flags;
  1282. X    str = flags & P_STRING;
  1283. X    if (flags & P_TTY) {
  1284. X    (void)signal (SIGINT, Temp_Intr_Handler);
  1285. X    Last_File = f;
  1286. X    Immediate_Mode (f, 1);
  1287. X    }
  1288. X    c = GETC;
  1289. X    if (flags & P_TTY) {
  1290. X    Immediate_Mode (f, 0);
  1291. X    (void)signal (SIGINT, Intr_Handler);
  1292. X    }
  1293. X    Tweak_Stream (f);
  1294. X    return c == EOF ? Eof : Make_Char (c);
  1295. X}
  1296. X
  1297. XObject P_Read_String (argc, argv) Object *argv; {
  1298. X    Object port;
  1299. X    register FILE *f;
  1300. X    register c, str;
  1301. X    register char *p;
  1302. X    char buf[MAX_STRING_LEN];
  1303. X
  1304. X    port = argc == 1 ? argv[0] : Curr_Input_Port;
  1305. X    Check_Input_Port (port);
  1306. X    f = PORT(port)->file;
  1307. X    str = PORT(port)->flags & P_STRING;
  1308. X    p = buf;
  1309. X    while (1) {
  1310. X    c = GETC;
  1311. X    if (c == EOF || c == '\n')
  1312. X        break;
  1313. X    if (p == buf+MAX_STRING_LEN)
  1314. X        break;
  1315. X    *p++ = c;
  1316. X    }
  1317. X    Tweak_Stream (f);
  1318. X    return c == EOF ? Eof : Make_String (buf, p-buf);
  1319. X}
  1320. X
  1321. XObject P_Read (argc, argv) Object *argv; {
  1322. X    return General_Read (argc == 1 ? argv[0] : Curr_Input_Port);
  1323. X}
  1324. X
  1325. XObject General_Read (port) Object port; {
  1326. X    register FILE *f;
  1327. X    register c, str;
  1328. X    Object ret;
  1329. X
  1330. X    Check_Input_Port (port);
  1331. X    Flush_Output (Curr_Output_Port);
  1332. X    f = PORT(port)->file;
  1333. X    str = PORT(port)->flags & P_STRING;
  1334. X    while (1) {
  1335. X    c = GETC;
  1336. X    if (c == EOF) {
  1337. X        ret = Eof;
  1338. X        break;
  1339. X    }
  1340. X    if (Whitespace (c))
  1341. X        continue;
  1342. X    if (c == ';') {
  1343. X        if (Skip_Comment (port) == EOF) {
  1344. X        ret = Eof;
  1345. X        break;
  1346. X        }
  1347. X        continue;
  1348. X    }
  1349. X    if (c == '(') {
  1350. X        ret = Read_Sequence (port, 0);
  1351. X    } else {
  1352. X        UNGETC;
  1353. X        ret = Read_Atom (port);
  1354. X    }
  1355. X    break;
  1356. X    }
  1357. X    Tweak_Stream (f);
  1358. X    return ret;
  1359. X}
  1360. X
  1361. XSkip_Comment (port) Object port; {
  1362. X    register FILE *f;
  1363. X    register c, str;
  1364. X
  1365. X    f = PORT(port)->file;
  1366. X    str = PORT(port)->flags & P_STRING;
  1367. X    do {
  1368. X    c = GETC;
  1369. X    } while (c != '\n' && c != EOF);
  1370. X    return c;
  1371. X}
  1372. X
  1373. XObject Read_Atom (port) Object port; {
  1374. X    Object ret;
  1375. X
  1376. X    ret = Read_Special (port);
  1377. X    if (TYPE(ret) == T_Special)
  1378. X    Primitive_Error ("syntax error");
  1379. X    return ret;
  1380. X}
  1381. X
  1382. XObject Read_Special (port) Object port; {
  1383. X    Object ret;
  1384. X    register c, str;
  1385. X    register FILE *f;
  1386. X    char buf[MAX_SYMBOL_LEN+1];
  1387. X    register char *p = buf;
  1388. X
  1389. X    f = PORT(port)->file;
  1390. X    str = PORT(port)->flags & P_STRING;
  1391. Xagain:
  1392. X    c = GETC;
  1393. X    switch (c) {
  1394. X    case EOF:
  1395. Xeof:
  1396. X    Tweak_Stream (f);
  1397. X    Primitive_Error ("premature end of file");
  1398. X    case ';':
  1399. X    if (Skip_Comment (port) == EOF)
  1400. X        goto eof;
  1401. X    goto again;
  1402. X    case ')':
  1403. X    SET(ret, T_Special, c);
  1404. X    return ret;
  1405. X    case '(':
  1406. X    return Read_Sequence (port, 0);
  1407. X    case '\'':
  1408. X    ret = Read_Atom (port);
  1409. X    ret = Cons (ret, Null);
  1410. X    return Cons (Sym_Quote, ret);
  1411. X    case '`':
  1412. X    ret = Read_Atom (port);
  1413. X    ret = Cons (ret, Null);
  1414. X    return Cons (Sym_Quasiquote, ret);
  1415. X    case ',':
  1416. X    c = GETC;
  1417. X    if (c == EOF)
  1418. X        goto eof;
  1419. X    if (c == '@') {
  1420. X        ret = Read_Atom (port);
  1421. X        ret = Cons (ret, Null);
  1422. X        return Cons (Sym_Unquote_Splicing, ret);
  1423. X    } else {
  1424. X        UNGETC;
  1425. X        ret = Read_Atom (port);
  1426. X        ret = Cons (ret, Null);
  1427. X        return Cons (Sym_Unquote, ret);
  1428. X    }
  1429. X    case '"':
  1430. X    return Read_String (port);
  1431. X    case '#':
  1432. X    ret = Read_Sharp (port);
  1433. X    if (TYPE(ret) == T_Special)
  1434. X        goto again;
  1435. X    return ret;
  1436. X    default:
  1437. X    if (Whitespace (c))
  1438. X        goto again;
  1439. X    if (c == '.') {
  1440. X        c = GETC;
  1441. X        if (c == EOF)
  1442. X        goto eof;
  1443. X        if (Whitespace (c)) {
  1444. X        SET(ret, T_Special, '.');
  1445. X        return ret;
  1446. X        }
  1447. X        *p++ = '.';
  1448. X    }
  1449. X    while (!Whitespace (c) && !Delimiter (c) && c != EOF) {
  1450. X        if (p == buf+MAX_SYMBOL_LEN)
  1451. X        Primitive_Error ("symbol too long");
  1452. X        if (c == '\\') {
  1453. X        c = GETC;
  1454. X        if (c == EOF)
  1455. X            break;
  1456. X        }
  1457. X        *p++ = c;
  1458. X        c = GETC;
  1459. X    }
  1460. X    *p = '\0';
  1461. X    if (c != EOF)
  1462. X        UNGETC;
  1463. X    ret = Read_Number_Maybe (buf);
  1464. X    if (Nullp (ret))
  1465. X        ret = Intern (buf);
  1466. X    return ret;
  1467. X    }
  1468. X    /*NOTREACHED*/
  1469. X}
  1470. X
  1471. XObject Read_Sequence (port, vec) Object port; {
  1472. X    Object ret, e, tail, t;
  1473. X    GC_Node3;
  1474. X
  1475. X    ret = tail = Null;
  1476. X    GC_Link3 (ret, tail, port);
  1477. X    while (1) {
  1478. X    e = Read_Special (port);
  1479. X    if (TYPE(e) == T_Special) {
  1480. X        if (CHAR(e) == ')') {
  1481. X        GC_Unlink;
  1482. X        return ret;
  1483. X        }
  1484. X        if (vec)
  1485. X        Primitive_Error ("wrong syntax in vector");
  1486. X        if (CHAR(e) == '.') {
  1487. X        if (Nullp (tail)) {
  1488. X            ret = Read_Atom (port);
  1489. X        } else {
  1490. X            e = Read_Atom (port);
  1491. X            Cdr (tail) = e;
  1492. X        }
  1493. X        e = Read_Special (port);
  1494. X        if (TYPE(e) == T_Special && CHAR(e) == ')') {
  1495. X            GC_Unlink;
  1496. X            return ret;
  1497. X        }
  1498. X        Primitive_Error ("dot in wrong context");
  1499. X        }
  1500. X        Primitive_Error ("syntax error");
  1501. X    }
  1502. X    t = Cons (e, Null);
  1503. X    if (!Nullp (tail))
  1504. X        Cdr (tail) = t;
  1505. X    else
  1506. X        ret = t;
  1507. X    tail = t;
  1508. X    }
  1509. X    /*NOTREACHED*/
  1510. X}
  1511. X
  1512. XObject Read_String (port) Object port; {
  1513. X    char buf[MAX_STRING_LEN];
  1514. X    register char *p = buf;
  1515. X    register FILE *f;
  1516. X    register n, c, oc, str;
  1517. X
  1518. X    f = PORT(port)->file;
  1519. X    str = PORT(port)->flags & P_STRING;
  1520. X    while (1) {
  1521. X    c = GETC;
  1522. X    if (c == EOF) {
  1523. Xeof:
  1524. X        Tweak_Stream (f);
  1525. X        Primitive_Error ("end of file in string");
  1526. X    }
  1527. X    if (c == '\\') {
  1528. X        c = GETC;
  1529. X        switch (c) {
  1530. X        case EOF: goto eof;
  1531. X        case 'b': c = '\b'; break;
  1532. X        case 't': c = '\t'; break;
  1533. X        case 'r': c = '\r'; break;
  1534. X        case 'n': c = '\n'; break;
  1535. X        case '0': case '1': case '2': case '3':
  1536. X        case '4': case '5': case '6': case '7':
  1537. X        oc = n = 0;
  1538. X        do {
  1539. X            oc <<= 3; oc += c - '0';
  1540. X            c = GETC;
  1541. X            if (c == EOF) goto eof;
  1542. X        } while (Octal (c) && ++n <= 2);
  1543. X        UNGETC;
  1544. X        c = oc;
  1545. X        }
  1546. X    } else if (c == '"')
  1547. X        break;
  1548. X    if (p == buf+MAX_STRING_LEN)
  1549. X        Primitive_Error ("string too long");
  1550. X    *p++ = c;
  1551. X    }
  1552. X    return Make_String (buf, p-buf);
  1553. X}
  1554. X
  1555. XObject Read_Sharp (port) Object port; {
  1556. X    register c, str;
  1557. X    register FILE *f;
  1558. X    register char *p;
  1559. X    char buf[MAX_SYMBOL_LEN+3];
  1560. X    Object ret;
  1561. X
  1562. X    f = PORT(port)->file;
  1563. X    str = PORT(port)->flags & P_STRING;
  1564. X    c = GETC;
  1565. X    if (c == EOF) {
  1566. Xeof:
  1567. X    Tweak_Stream (f);
  1568. X    Primitive_Error ("end of file after `#'");
  1569. X    }
  1570. X    switch (c) {
  1571. X    case '(':
  1572. X    return P_List_To_Vector (Read_Sequence (port, 1));
  1573. X    case 'b': case 'o': case 'd': case 'x':
  1574. X    p = buf; *p++ = '#'; *p++ = c;
  1575. X    while (1) {
  1576. X        c = GETC;
  1577. X        if (c == EOF)
  1578. X        goto eof;
  1579. X        if (p == buf+MAX_SYMBOL_LEN+2)
  1580. X        Primitive_Error ("number too long");
  1581. X        if (Whitespace (c) || Delimiter (c))
  1582. X        break;
  1583. X        *p++ = c;
  1584. X    }
  1585. X    UNGETC;
  1586. X    *p = '\0';
  1587. X    ret = Read_Number_Maybe (buf);
  1588. X    if (Nullp (ret))
  1589. X        Primitive_Error ("radix not followed by a valid number");
  1590. X    return ret;
  1591. X    case '\\':
  1592. X    p = buf;
  1593. X    c = GETC;
  1594. X    if (c == EOF)
  1595. X        goto eof;
  1596. X    *p++ = c;
  1597. X    while (1) {
  1598. X        c = GETC;
  1599. X        if (c == EOF)
  1600. X        goto eof;
  1601. X        if (Whitespace (c) || Delimiter (c))
  1602. X        break;
  1603. X        if (p == buf+9)
  1604. X        goto bad;
  1605. X        *p++ = c;
  1606. X    }
  1607. X    UNGETC;
  1608. X    *p = '\0';
  1609. X    if (p == buf+1)
  1610. X        return Make_Char (*buf);
  1611. X    if (p == buf+3) {
  1612. X        for (c = 0, p = buf; p < buf+3 && Octal (*p); p++)
  1613. X        c = (c << 3) | (*p - '0');
  1614. X        if (p == buf+3)
  1615. X        return Make_Char (c);
  1616. X    }
  1617. X    for (p = buf; *p; p++)
  1618. X        if (isupper (*p))
  1619. X        *p = tolower (*p);
  1620. X    if (strcmp (buf, "space") == 0)
  1621. X        return Make_Char (' ');
  1622. X    if (strcmp (buf, "newline") == 0)
  1623. X        return Make_Char ('\n');
  1624. X    if (strcmp (buf, "return") == 0)
  1625. X        return Make_Char ('\r');
  1626. X    if (strcmp (buf, "tab") == 0)
  1627. X        return Make_Char ('\t');
  1628. X    if (strcmp (buf, "formfeed") == 0)
  1629. X        return Make_Char ('\f');
  1630. X    if (strcmp (buf, "backspace") == 0)
  1631. X        return Make_Char ('\b');
  1632. X    goto bad;
  1633. X    case 'f': case 'F':
  1634. X    return False;
  1635. X    case 't': case 'T':
  1636. X    return True;
  1637. X    case 'v': case 'V':
  1638. X    return Void;
  1639. X    case '!':                         /* Kludge for interpreter files */
  1640. X    if (Skip_Comment (port) == EOF)
  1641. X        return Eof;
  1642. X    return Special;
  1643. X    default:
  1644. Xbad:
  1645. X    Primitive_Error ("syntax error after `#'");
  1646. X    }
  1647. X    /*NOTREACHED*/
  1648. X}
  1649. X
  1650. XObject Read_Number_Maybe (buf) char *buf; {
  1651. X    register char *p;
  1652. X    register c, digit = 0, expo = 0, neg = 0, point = 0, base = 10;
  1653. X    register i;
  1654. X
  1655. X    if (buf[0] == '#') {
  1656. X    switch (buf[1]) {
  1657. X    case 'b': base = 2; break;
  1658. X    case 'o': base = 8; break;
  1659. X    case 'd': break;
  1660. X    case 'x': base = 16; break;
  1661. X    default: return Null;
  1662. X    }
  1663. X    buf += 2;
  1664. X    }
  1665. X    p = buf;
  1666. X    if (*p == '+' || (neg = *p == '-'))
  1667. X    p++;
  1668. X    for ( ; c = *p; p++) {
  1669. X    if (c == '.') {
  1670. X        if (point++)
  1671. X        return Null;
  1672. X    } else if (base != 16 && (c == 'e' || c == 'E')) {
  1673. X        if (expo++)
  1674. X        return Null;
  1675. X        if (p[1] == '+' || p[1] == '-')
  1676. X        p++;
  1677. X    } else if (base == 16 && !index ("0123456789abcdefABCDEF", c)) {
  1678. X        return Null;
  1679. X    } else if (base < 16 && (c < '0' || c > '0' + base-1)) {
  1680. X        return Null;
  1681. X    } else digit++;
  1682. X    }
  1683. X    if (!digit)
  1684. X    return Null;
  1685. X    if (point || expo) {
  1686. X    if (base != 10)
  1687. X        Primitive_Error ("reals must be given in decimal");
  1688. X    return Make_Reduced_Flonum (atof (buf));
  1689. X    }
  1690. X    for (i = 0, p = buf; c = *p; p++) {
  1691. X    if (c == '-' || c == '+') {
  1692. X        buf++;
  1693. X        continue;
  1694. X    }
  1695. X    if (base == 16) {
  1696. X        if (isupper (c))
  1697. X        c = tolower (c);
  1698. X        if (c >= 'a')
  1699. X        c = '9' + c - 'a' + 1;
  1700. X    }
  1701. X    i = base * i + c - '0';
  1702. X    if (!FIXNUM_FITS(neg ? -i : i))
  1703. X        return Make_Bignum (buf, neg, base);
  1704. X    }
  1705. X    if (neg)
  1706. X    i = -i;
  1707. X    return Make_Fixnum (i);
  1708. X}
  1709. X
  1710. X#ifdef TERMIO
  1711. X
  1712. XImmediate_Mode (f, on) FILE *f; {
  1713. X    static struct termio b;
  1714. X    static oldlflag, oldeof;
  1715. X
  1716. X    if (on) {
  1717. X    (void)ioctl (fileno (f), TCGETA, &b);
  1718. X    oldlflag = b.c_lflag;
  1719. X    oldeof = b.c_cc[VEOF];
  1720. X    b.c_lflag &= ~ICANON;
  1721. X    b.c_cc[VEOF] = 1;
  1722. X    } else {
  1723. X    b.c_lflag = oldlflag;
  1724. X    b.c_cc[VEOF] = oldeof;
  1725. X    }
  1726. X    (void)ioctl (fileno (f), TCSETA, &b);
  1727. X}
  1728. X
  1729. X#else
  1730. X
  1731. XImmediate_Mode (f, on) FILE *f; {
  1732. X    static struct sgttyb b;
  1733. X    static oldflags;
  1734. X
  1735. X    if (on) {
  1736. X    if (ioctl (fileno (f), TIOCGETP, &b) == -1)
  1737. X        perror("getp");
  1738. X    oldflags = b.sg_flags;
  1739. X    b.sg_flags |= CBREAK;
  1740. X    } else {
  1741. X    b.sg_flags = oldflags;
  1742. X    }
  1743. X    if (ioctl (fileno (f), TIOCSETP, &b) == -1)
  1744. X    perror("setp");
  1745. X}
  1746. X
  1747. X#endif
  1748. END_OF_src/read.c
  1749. if test 12649 -ne `wc -c <src/read.c`; then
  1750.     echo shar: \"src/read.c\" unpacked with wrong size!
  1751. fi
  1752. # end of overwriting check
  1753. fi
  1754. if test -f src/io.c -a "${1}" != "-c" ; then 
  1755.   echo shar: Will not over-write existing file \"src/io.c\"
  1756. else
  1757. echo shar: Extracting \"src/io.c\" \(8517 characters\)
  1758. sed "s/^X//" >src/io.c <<'END_OF_src/io.c'
  1759. X/* Input and output (ports etc.)
  1760. X */
  1761. X
  1762. X#include <errno.h>
  1763. X#include <pwd.h>
  1764. X#include <sys/types.h>
  1765. X#include <sys/param.h>
  1766. X#include <sys/stat.h>
  1767. X
  1768. X#include "scheme.h"
  1769. X
  1770. Xstatic Max_Open_Files;
  1771. Xstatic Object Open_Files[MAX_MAX_OPEN_FILES];
  1772. X
  1773. XObject Curr_Input_Port, Curr_Output_Port;
  1774. XObject Standard_Input_Port, Standard_Output_Port;
  1775. X
  1776. XObject Make_Port();
  1777. Xvoid Close_Lost_Files();
  1778. X
  1779. XInit_Io () {
  1780. X    register Object *p;
  1781. X
  1782. X#ifdef MAX_OFILES
  1783. X    Max_Open_Files = MAX_OFILES;
  1784. X#else
  1785. X    Max_Open_Files = getdtablesize ();
  1786. X#endif
  1787. X    if (Max_Open_Files > MAX_MAX_OPEN_FILES)
  1788. X    Max_Open_Files = MAX_MAX_OPEN_FILES;
  1789. X    for (p = Open_Files; p < Open_Files+Max_Open_Files; p++)
  1790. X    *p = Null;
  1791. X    Standard_Input_Port = Make_Port (P_INPUT, stdin, Make_String ("stdin", 5));
  1792. X    Standard_Output_Port = Make_Port (0, stdout, Make_String ("stdout", 6));
  1793. X    Curr_Input_Port = Standard_Input_Port;
  1794. X    Curr_Output_Port = Standard_Output_Port;
  1795. X    Global_GC_Link (Standard_Input_Port);
  1796. X    Global_GC_Link (Standard_Output_Port);
  1797. X    Global_GC_Link (Curr_Input_Port);
  1798. X    Global_GC_Link (Curr_Output_Port);
  1799. X    Register_After_GC (Close_Lost_Files);
  1800. X}
  1801. X
  1802. XReset_IO (destructive) {
  1803. X    Discard_Input (Curr_Input_Port);
  1804. X    if (destructive)
  1805. X    Discard_Output (Curr_Output_Port);
  1806. X    else
  1807. X    Flush_Output (Curr_Output_Port);
  1808. X    Curr_Input_Port = Standard_Input_Port;
  1809. X    Curr_Output_Port = Standard_Output_Port;
  1810. X}
  1811. X
  1812. XObject Make_Port (flags, f, name) FILE *f; Object name; {
  1813. X    Object port;
  1814. X    register char *p;
  1815. X    GC_Node;
  1816. X
  1817. X    if (f && isatty (fileno (f)))
  1818. X    flags |= P_TTY;
  1819. X    GC_Link (name);
  1820. X    p = Get_Bytes (sizeof (struct S_Port));
  1821. X    SET(port, T_Port, (struct S_Port *)p);
  1822. X    PORT(port)->flags = flags|P_OPEN;
  1823. X    PORT(port)->file = f;
  1824. X    PORT(port)->name = name;
  1825. X    PORT(port)->ptr = 0;
  1826. X    GC_Unlink;
  1827. X    return port;
  1828. X}
  1829. X
  1830. XObject P_Port_File_Name (p) Object p; {
  1831. X    Check_Type (p, T_Port);
  1832. X    return (PORT(p)->flags & P_STRING) ? False : PORT(p)->name;
  1833. X}
  1834. X
  1835. XObject P_Eof_Objectp (x) Object x; {
  1836. X    return TYPE(x) == T_End_Of_File ? True : False;
  1837. X}
  1838. X
  1839. XObject P_Curr_Input_Port () { return Curr_Input_Port; }
  1840. X
  1841. XObject P_Curr_Output_Port () { return Curr_Output_Port; }
  1842. X
  1843. XObject P_Input_Portp (x) Object x; {
  1844. X    return TYPE(x) == T_Port && (PORT(x)->flags & P_INPUT) ? True : False;
  1845. X}
  1846. X
  1847. XObject P_Output_Portp (x) Object x; {
  1848. X    return TYPE(x) == T_Port && !(PORT(x)->flags & P_INPUT) ? True : False;
  1849. X}
  1850. X
  1851. Xvoid Close_Lost_Files () {
  1852. X    register Object *p, *tag;
  1853. X
  1854. X    for (p = Open_Files; p < Open_Files+Max_Open_Files; p++) {
  1855. X    if (Nullp (*p)) continue;
  1856. X    if (TYPE(*p) != T_Port)
  1857. X        Panic ("bad type in file table");
  1858. X    tag = &PORT(*p)->name;
  1859. X    if (TYPE(*tag) == T_Broken_Heart) {
  1860. X        SETPOINTER(*p, POINTER(*tag));
  1861. X    } else {
  1862. X        (void)fclose (PORT(*p)->file);
  1863. X        *p = Null;
  1864. X    }
  1865. X    }
  1866. X}
  1867. X
  1868. XClose_All_Files () {
  1869. X    register Object *p;
  1870. X
  1871. X    for (p = Open_Files; p < Open_Files+Max_Open_Files; p++) {
  1872. X    if (Nullp (*p)) continue;
  1873. X    (void)fclose (PORT(*p)->file);
  1874. X    PORT(*p)->flags &= ~P_OPEN;
  1875. X    *p = Null;
  1876. X    }
  1877. X}
  1878. X
  1879. XRegister_File (port) Object port; {
  1880. X    register Object *p;
  1881. X
  1882. X    for (p = Open_Files; p < Open_Files+Max_Open_Files; p++)
  1883. X    if (Nullp (*p)) break;
  1884. X    if (p == Open_Files+Max_Open_Files)
  1885. X    Primitive_Error ("no more slots for open files.\n");
  1886. X    *p = port;
  1887. X}
  1888. X
  1889. XObject Get_File_Name (name) Object name; {
  1890. X    register len;
  1891. X
  1892. X    if (TYPE(name) == T_Symbol)
  1893. X    name = SYMBOL(name)->name;
  1894. X    else if (TYPE(name) != T_String)
  1895. X    Wrong_Type_Combination (name, "string or symbol");
  1896. X    if ((len = STRING(name)->size) > MAXPATHLEN || len == 0)
  1897. X    Primitive_Error ("invalid file name");
  1898. X    return name;
  1899. X}
  1900. X
  1901. Xchar *Internal_Tilde_Expand (s, dirp) register char *s, **dirp; {
  1902. X    register char *p; 
  1903. X    struct passwd *pw, *getpwnam();
  1904. X
  1905. X    if (*s != '~')
  1906. X    return 0;
  1907. X    for (p = s+1; *p && *p != '/'; p++) ;
  1908. X    *p = '\0';
  1909. X    if (p == s+1) {
  1910. X    if ((*dirp = getenv ("HOME")) == 0)
  1911. X        *dirp = "";
  1912. X    } else {
  1913. X    if ((pw = getpwnam (s+1)) == 0)
  1914. X        Primitive_Error ("unknown user: ~a", Make_String (s+1, p-s-1));
  1915. X    *dirp = pw->pw_dir;
  1916. X    } 
  1917. X    return p;
  1918. X}
  1919. X
  1920. XObject General_File_Operation (s, op) Object s; register op; {
  1921. X    register char *r;
  1922. X    register n;
  1923. X    Object fn;
  1924. X
  1925. X    fn = Get_File_Name (s);
  1926. X    n = STRING(fn)->size;
  1927. X    r = alloca (n+1);
  1928. X    bcopy (STRING(fn)->data, r, n);
  1929. X    r[n] = '\0';
  1930. X    switch (op) {
  1931. X    case 0: {
  1932. X    char *p, *dir;
  1933. X    if ((p = Internal_Tilde_Expand (r, &dir)) == 0)
  1934. X        return s;
  1935. X    r = alloca (strlen (dir) + 1 + strlen (p));
  1936. X    sprintf (r, "%s/%s", dir, p+1);
  1937. X    return Make_String (r, strlen (r));
  1938. X    }
  1939. X    case 1: {
  1940. X    struct stat st;
  1941. X    return stat (r, &st) == 0 || errno != ENOENT ? True : False;
  1942. X    }}
  1943. X    /*NOTREACHED*/
  1944. X}
  1945. X
  1946. XObject P_Tilde_Expand (s) Object s; {
  1947. X    return General_File_Operation (s, 0);
  1948. X}
  1949. X
  1950. XObject P_File_Existsp (s) Object s; {
  1951. X    return General_File_Operation (s, 1);
  1952. X}
  1953. X
  1954. XObject Open_File (name, flags, err) register char *name; {
  1955. X    register FILE *f;
  1956. X    char *dir, *p;
  1957. X    Object fn, port;
  1958. X    struct stat st;
  1959. X
  1960. X    if ((p = Internal_Tilde_Expand (name, &dir))) {
  1961. X    name = alloca (strlen (dir) + 1 + strlen (p));
  1962. X    sprintf (name, "%s/%s", dir, p+1);
  1963. X    }
  1964. X    if (!err && stat (name, &st) == -1 && errno == ENOENT)
  1965. X    return Null;
  1966. X    fn = Make_String (name, strlen (name));
  1967. X    if ((f = fopen (name, (flags & P_INPUT) ? "r" : "w")) == NULL) {
  1968. X    Saved_Errno = errno;  /* errno valid here? */
  1969. X    Primitive_Error ("~s: ~E", fn);
  1970. X    }
  1971. X    port = Make_Port (flags, f, fn);
  1972. X    Register_File (port);
  1973. X    return port;
  1974. X}
  1975. X
  1976. XObject General_Open_File (name, flags, path) Object name, path; {
  1977. X    Object port, pref;
  1978. X    register char *buf, *fn;
  1979. X    register plen, len, blen = 0, gotpath = 0;
  1980. X
  1981. X    name = Get_File_Name (name);
  1982. X    len = STRING(name)->size;
  1983. X    fn = STRING(name)->data;
  1984. X    if (fn[0] != '/' && fn[0] != '~') {
  1985. X    for ( ; TYPE(path) == T_Pair; path = Cdr (path)) {
  1986. X        pref = Car (path);
  1987. X        if (TYPE(pref) == T_Symbol)
  1988. X        pref = SYMBOL(pref)->name;
  1989. X        if (TYPE(pref) != T_String)
  1990. X        continue;
  1991. X        gotpath = 1;
  1992. X        if ((plen = STRING(pref)->size) > MAXPATHLEN || plen == 0)
  1993. X        continue;
  1994. X        if (len + plen + 2 > blen)
  1995. X        buf = alloca (blen = len + plen + 2);
  1996. X        bcopy (STRING(pref)->data, buf, plen);
  1997. X        if (buf[plen-1] != '/')
  1998. X        buf[plen++] = '/';
  1999. X        bcopy (fn, buf+plen, len);
  2000. X        buf[len+plen] = '\0';
  2001. X        port = Open_File (buf, flags, 0);
  2002. X        /* No GC has been taken place in Open_File() if it returns Null.
  2003. X         */
  2004. X        if (!Nullp (port))
  2005. X        return port;
  2006. X    }
  2007. X    }
  2008. X    if (gotpath)
  2009. X    Primitive_Error ("file ~s not found", name);
  2010. X    if (len + 1 > blen)
  2011. X    buf = alloca (len + 1);
  2012. X    bcopy (fn, buf, len);
  2013. X    buf[len] = '\0';
  2014. X    return Open_File (buf, flags, 1);
  2015. X}
  2016. X
  2017. XObject P_Open_Input_File (name) Object name; {
  2018. X    return General_Open_File (name, P_INPUT, Null);
  2019. X}
  2020. X
  2021. XObject P_Open_Output_File (name) Object name; {
  2022. X    return General_Open_File (name, 0, Null);
  2023. X}
  2024. X
  2025. XObject P_Close_Port (port) Object port; {
  2026. X    register Object *p;
  2027. X    register flags;
  2028. X
  2029. X    Check_Type (port, T_Port);
  2030. X    flags = PORT(port)->flags;
  2031. X    if (!(flags & P_OPEN))
  2032. X    return True;
  2033. X    if (!(flags & P_STRING))
  2034. X    (void)fclose (PORT(port)->file);
  2035. X    PORT(port)->flags &= ~P_OPEN;
  2036. X    if (!(flags & P_STRING)) {
  2037. X    for (p = Open_Files; p < Open_Files+Max_Open_Files; p++) {
  2038. X        if (EQ(port,*p))
  2039. X        *p = Null;
  2040. X    }
  2041. X    }
  2042. X    return Void;
  2043. X}
  2044. X
  2045. X#define General_With(prim,curr,flags) Object prim (name, thunk)\
  2046. X    Object name, thunk; {\
  2047. X    Object old, ret;\
  2048. X    GC_Node2;\
  2049. X\
  2050. X    Check_Procedure (thunk);\
  2051. X    old = curr;\
  2052. X    GC_Link2 (thunk, old);\
  2053. X    curr = General_Open_File (name, flags, Null);\
  2054. X    ret = Funcall (thunk, Null, 0);\
  2055. X    P_Close_Port (curr);\
  2056. X    GC_Unlink;\
  2057. X    curr = old;\
  2058. X    return ret;\
  2059. X}
  2060. X
  2061. XGeneral_With (P_With_Input, Curr_Input_Port, P_INPUT)
  2062. XGeneral_With (P_With_Output, Curr_Output_Port, 0)
  2063. X
  2064. XObject General_Call_With (name, flags, proc) Object name, proc; {
  2065. X    Object port, ret;
  2066. X    GC_Node2;
  2067. X
  2068. X    Check_Procedure (proc);
  2069. X    GC_Link2 (proc, port);
  2070. X    port = General_Open_File (name, flags, Null);
  2071. X    port = Cons (port, Null);
  2072. X    ret = Funcall (proc, port, 0);
  2073. X    P_Close_Port (Car (port));
  2074. X    GC_Unlink;
  2075. X    return ret;
  2076. X}
  2077. X
  2078. XObject P_Call_With_Input (name, proc) Object name, proc; {
  2079. X    return General_Call_With (name, P_INPUT, proc);
  2080. X}
  2081. X
  2082. XObject P_Call_With_Output (name, proc) Object name, proc; {
  2083. X    return General_Call_With (name, 0, proc);
  2084. X}
  2085. X
  2086. XObject P_Open_Input_String (string) Object string; {
  2087. X    Check_Type (string, T_String);
  2088. X    return Make_Port (P_STRING|P_INPUT, (FILE *)0, string);
  2089. X}
  2090. X
  2091. XObject P_Open_Output_String () {
  2092. X    return Make_Port (P_STRING, (FILE *)0, Make_String ((char *)0, 0));
  2093. X}
  2094. END_OF_src/io.c
  2095. if test 8517 -ne `wc -c <src/io.c`; then
  2096.     echo shar: \"src/io.c\" unpacked with wrong size!
  2097. fi
  2098. # end of overwriting check
  2099. fi
  2100. if test -f src/load.c -a "${1}" != "-c" ; then 
  2101.   echo shar: Will not over-write existing file \"src/load.c\"
  2102. else
  2103. echo shar: Extracting \"src/load.c\" \(4515 characters\)
  2104. sed "s/^X//" >src/load.c <<'END_OF_src/load.c'
  2105. X/* Loading of source and object files
  2106. X */
  2107. X
  2108. X#include <signal.h>
  2109. X
  2110. X#include "scheme.h"
  2111. X
  2112. X#ifdef COFF
  2113. X#  include <filehdr.h>
  2114. X#  include <syms.h>
  2115. X#  undef TYPE         /* ldfnc.h defines a TYPE macro. */
  2116. X#  include <ldfcn.h>
  2117. X#  undef TYPE
  2118. X#  ifdef USE_BITFIELDS
  2119. X#    define TYPE(x) ((int)(x).s.type)
  2120. X#  else
  2121. X#    define TYPE(x) ((int)((x) >> VALBITS))
  2122. X#  endif
  2123. X#else
  2124. X#  include <a.out.h>
  2125. X#  include <sys/types.h>
  2126. X#endif
  2127. X
  2128. Xstatic Object V_Load_Path, V_Load_Noisilyp, V_Load_Libraries;
  2129. X
  2130. X#ifdef CAN_LOAD_OBJ
  2131. X#  ifdef gcc
  2132. X#    define Default_Load_Libraries "/usr/new/ghs/lib/libc.a"
  2133. X#  else
  2134. X#    define Default_Load_Libraries "-lc"
  2135. X#  endif
  2136. X#else
  2137. X#  define Default_Load_Libraries ""
  2138. X#endif
  2139. X
  2140. X#if defined(CAN_DUMP) || defined(CAN_LOAD_OBJ)
  2141. Xchar Loader_Input[20];
  2142. X#endif
  2143. X#ifdef CAN_LOAD_OBJ
  2144. Xstatic char Loader_Output[20];
  2145. X#endif
  2146. X
  2147. XInit_Load () {
  2148. X    Define_Variable (&V_Load_Path, "load-path",
  2149. X    Cons (Make_String (".", 1),
  2150. X    Cons (Make_String (DEF_LOAD_DIR, sizeof (DEF_LOAD_DIR) - 1), Null)));
  2151. X    Define_Variable (&V_Load_Noisilyp, "load-noisily?", False);
  2152. X    Define_Variable (&V_Load_Libraries, "load-libraries", 
  2153. X    Make_String (Default_Load_Libraries, sizeof Default_Load_Libraries-1));
  2154. X}
  2155. X
  2156. XObject General_Load (name, env) Object name, env; {
  2157. X    register char *p;
  2158. X    register struct S_String *str;
  2159. X    Object oldenv, port;
  2160. X    GC_Node2;
  2161. X
  2162. X    Check_Type (env, T_Environment);
  2163. X    oldenv = The_Environment;
  2164. X    GC_Link2 (env, oldenv);
  2165. X    port = General_Open_File (name, P_INPUT, Val (V_Load_Path));
  2166. X    str = STRING(PORT(port)->name);
  2167. X    Switch_Environment (env);
  2168. X    p = str->data + str->size;
  2169. X    if (str->size >= 2 && *--p == 'o' && *--p == '.') {
  2170. X#ifdef CAN_LOAD_OBJ
  2171. X    Load_Object (port, str);
  2172. X#else
  2173. X    ;
  2174. X#endif
  2175. X    } else
  2176. X    Load_Source (port);
  2177. X    Switch_Environment (oldenv);
  2178. X    GC_Unlink;
  2179. X    return Void;
  2180. X}
  2181. X
  2182. XObject P_Load (argc, argv) register argc; register Object *argv; {
  2183. X    return General_Load (argv[0], argc == 1 ? The_Environment : argv[1]);
  2184. X}
  2185. X
  2186. XLoad_Source (port) Object port; {
  2187. X    Object val;
  2188. X    GC_Node;
  2189. X
  2190. X    GC_Link (port);
  2191. X    while (1) {
  2192. X    val = General_Read (port);
  2193. X    if (TYPE(val) == T_End_Of_File)
  2194. X        break;
  2195. X    val = Eval (val);
  2196. X    if (Truep (Val (V_Load_Noisilyp))) {
  2197. X        Print (val);
  2198. X        P_Newline (0);
  2199. X    }
  2200. X    }
  2201. X    P_Close_Port (port);
  2202. X    GC_Unlink;
  2203. X}
  2204. X
  2205. X#ifdef CAN_LOAD_OBJ
  2206. XLoad_Object (port, fn) Object port; register struct S_String *fn; {
  2207. X    struct exec hdr;
  2208. X    register char *brk, *obrk, *buf, *lp, *li;
  2209. X    register n, f;
  2210. X    Object libs;
  2211. X    FILE *fp;
  2212. X
  2213. X    n = fread ((char *)&hdr, sizeof (hdr), 1, PORT(port)->file);
  2214. X    P_Close_Port (port);
  2215. X    if (n == 0 || hdr.a_magic != OMAGIC)
  2216. X    Primitive_Error ("not a valid object file");
  2217. X    strcpy (Loader_Output, "/tmp/ldXXXXXX");
  2218. X    mktemp (Loader_Output);
  2219. X    buf = alloca (fn->size + strlen (myname) + 500);
  2220. X    obrk = brk = sbrk (0);
  2221. X    brk = (char *)((int)brk + 7 & ~7);
  2222. X    libs = Val (V_Load_Libraries);
  2223. X    if (TYPE(libs) == T_String) {
  2224. X        if ((n = STRING(libs)->size) > 400)
  2225. X        Primitive_Error ("too many load libraries");
  2226. X    lp = STRING(libs)->data;
  2227. X    } else {
  2228. X    lp = "-lc"; n = 3;
  2229. X    }
  2230. X    li = Loader_Input;
  2231. X    if (li[0] == 0)
  2232. X    li = myname;
  2233. X#ifdef XFLAG_BROKEN
  2234. X    sprintf (buf, "/bin/ld -N -A %s -T %x %.*s -o %s %.*s",
  2235. X#else
  2236. X    sprintf (buf, "/bin/ld -N -x -A %s -T %x %.*s -o %s %.*s",
  2237. X#endif
  2238. X    li, brk, fn->size, fn->data, Loader_Output, n, lp);
  2239. X    if (system (buf) != 0) {
  2240. X    (void)unlink (Loader_Output);
  2241. X    Primitive_Error ("system linker failed");
  2242. X    }
  2243. X    Disable_Interrupts;               /* To ensure that f gets closed */
  2244. X    if ((f = open (Loader_Output, 0)) == -1) {
  2245. X    (void)unlink (Loader_Output);
  2246. X    Primitive_Error ("cannot open tempfile");
  2247. X    }
  2248. X    if (Loader_Input[0])
  2249. X    (void)unlink(Loader_Input);
  2250. X    strcpy (Loader_Input, Loader_Output);
  2251. X    if (read (f, (char *)&hdr, sizeof (hdr)) != sizeof (hdr)) {
  2252. Xerr:
  2253. X    close (f);
  2254. X    Primitive_Error ("corrupt tempfile (/bin/ld is broken)");
  2255. X    }
  2256. X    n = hdr.a_text + hdr.a_data + hdr.a_bss;
  2257. X    n += brk - obrk;
  2258. X    if (sbrk (n) == (char *)-1) {
  2259. X    close (f);
  2260. X    Primitive_Error ("not enough memory to load object file");
  2261. X    }
  2262. X    bzero (obrk, n);
  2263. X    n -= hdr.a_bss;
  2264. X    if (read (f, brk, n) != n)
  2265. X    goto err;
  2266. X    if ((fp = fdopen (f, "r")) == NULL) {
  2267. X    close (f);
  2268. X    Primitive_Error ("cannot fdopen object file");
  2269. X    }
  2270. X    if (The_Symbols)
  2271. X    Free_Symbols (The_Symbols);
  2272. X    The_Symbols = Snarf_Symbols (fp, &hdr);
  2273. X    fclose (fp);
  2274. X    Call_Initializers (The_Symbols, brk);
  2275. X    Enable_Interrupts;
  2276. X}
  2277. X
  2278. XFinit_Load () {
  2279. X    if (Loader_Input[0])
  2280. X    (void)unlink (Loader_Input);
  2281. X}
  2282. X#endif
  2283. END_OF_src/load.c
  2284. if test 4515 -ne `wc -c <src/load.c`; then
  2285.     echo shar: \"src/load.c\" unpacked with wrong size!
  2286. fi
  2287. # end of overwriting check
  2288. fi
  2289. if test -f src/auto.c -a "${1}" != "-c" ; then 
  2290.   echo shar: Will not over-write existing file \"src/auto.c\"
  2291. else
  2292. echo shar: Extracting \"src/auto.c\" \(1192 characters\)
  2293. sed "s/^X//" >src/auto.c <<'END_OF_src/auto.c'
  2294. X/* Autoloading
  2295. X */
  2296. X
  2297. X#include "scheme.h"
  2298. X
  2299. XObject V_Autoload_Notifyp;
  2300. X
  2301. XInit_Auto () {
  2302. X    Define_Variable (&V_Autoload_Notifyp, "autoload-notify?", True);
  2303. X}
  2304. X
  2305. XObject P_Autoload (sym, file) Object sym, file; {
  2306. X    Object al, ret;
  2307. X    register char *p;
  2308. X    GC_Node3;
  2309. X
  2310. X    al = Null;
  2311. X    Check_Type (sym, T_Symbol);
  2312. X    if (TYPE(file) != T_Symbol && TYPE(file) != T_String)
  2313. X    Wrong_Type_Combination (file, "string or symbol");
  2314. X    GC_Link3 (al, sym, file);
  2315. X    p = Get_Bytes (sizeof (struct S_Autoload));
  2316. X    SET(al, T_Autoload, (struct S_Autoload *)p);
  2317. X    AUTOLOAD(al)->file = file;
  2318. X    AUTOLOAD(al)->env = The_Environment;
  2319. X    al = Cons (al, Null);
  2320. X    al = Cons (sym, al);
  2321. X    ret = P_Define (al);
  2322. X    GC_Unlink;
  2323. X    return ret;
  2324. X}
  2325. X
  2326. XObject Do_Autoload (sym, al) Object sym, al; {
  2327. X    Object val, a[1];
  2328. X    GC_Node;
  2329. X
  2330. X    if (Truep (Val (V_Autoload_Notifyp))) {
  2331. X    a[0] = AUTOLOAD(al)->file;
  2332. X    Format (Standard_Output_Port, "[Autoloading ~s]~%", 18, 1, a);
  2333. X    }
  2334. X    GC_Link (sym);
  2335. X    (void)General_Load (AUTOLOAD(al)->file, AUTOLOAD(al)->env);
  2336. X    GC_Unlink;
  2337. X    val = SYMBOL(sym)->value;
  2338. X    if (TYPE(val) == T_Autoload)
  2339. X    Primitive_Error ("autoloading failed to define ~s", sym);
  2340. X    return val;
  2341. X}
  2342. END_OF_src/auto.c
  2343. if test 1192 -ne `wc -c <src/auto.c`; then
  2344.     echo shar: \"src/auto.c\" unpacked with wrong size!
  2345. fi
  2346. # end of overwriting check
  2347. fi
  2348. if test -f src/alloca.s.vax -a "${1}" != "-c" ; then 
  2349.   echo shar: Will not over-write existing file \"src/alloca.s.vax\"
  2350. else
  2351. echo shar: Extracting \"src/alloca.s.vax\" \(0 character\)
  2352. sed "s/^X//" >src/alloca.s.vax <<'END_OF_src/alloca.s.vax'
  2353. END_OF_src/alloca.s.vax
  2354. if test 0 -ne `wc -c <src/alloca.s.vax`; then
  2355.     echo shar: \"src/alloca.s.vax\" unpacked with wrong size!
  2356. fi
  2357. # end of overwriting check
  2358. fi
  2359. echo shar: End of archive 5 \(of 14\).
  2360. cp /dev/null ark5isdone
  2361. MISSING=""
  2362. for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 ; do
  2363.     if test ! -f ark${I}isdone ; then
  2364.     MISSING="${MISSING} ${I}"
  2365.     fi
  2366. done
  2367. if test "${MISSING}" = "" ; then
  2368.     echo You have unpacked all 14 archives.
  2369.     rm -f ark[1-9]isdone ark[1-9][0-9]isdone
  2370. else
  2371.     echo You still need to unpack the following archives:
  2372.     echo "        " ${MISSING}
  2373. fi
  2374. ##  End of shell archive.
  2375. exit 0
  2376.