home *** CD-ROM | disk | FTP | other *** search
/ Computer Club Elmshorn Atari PD / CCE_PD.iso / pc / 0400 / CCE_0442.ZIP / CCE_0442.PD / XSCHEM28 / XSFTAB.C < prev    next >
C/C++ Source or Header  |  1991-09-16  |  13KB  |  486 lines
  1. /* xsftab.c - built-in function table */
  2. /*    Copyright (c) 1988, by David Michael Betz
  3.     All Rights Reserved
  4.     Permission is granted for unrestricted non-commercial use    */
  5.  
  6. #include "xscheme.h"
  7.  
  8. /* external variables */
  9. extern LVAL s_stdin,s_stdout;
  10.  
  11. /* external functions */
  12. extern void
  13.     xapply(),xcallcc(),xmap(),xmap1(),xforeach(),xforeach1(),
  14.     xforce(),xforce1(),xcallwi(),xcallwo(),xwithfile1(),
  15.     xload(),xloadnoisily(),xload1(),xsendsuper(),clnew();
  16. extern LVAL
  17.     clisnew(),clanswer(),obisnew(),obclass(),obshow(),
  18.     xcons(),xcar(),xcdr(),
  19.     xcaar(),xcadr(),xcdar(),xcddr(),
  20.     xcaaar(),xcaadr(),xcadar(),xcaddr(),
  21.     xcdaar(),xcdadr(),xcddar(),xcdddr(),
  22.     xcaaaar(),xcaaadr(),xcaadar(),xcaaddr(),
  23.     xcadaar(),xcadadr(),xcaddar(),xcadddr(),
  24.     xcdaaar(),xcdaadr(),xcdadar(),xcdaddr(),
  25.     xcddaar(),xcddadr(),xcdddar(),xcddddr(),
  26.     xsetcar(),xsetcdr(),xlist(),xliststar(),
  27.     xappend(),xreverse(),xlastpair(),xlength(),xlistref(),xlisttail(),
  28.     xmember(),xmemv(),xmemq(),xassoc(),xassv(),xassq(),
  29.     xsymvalue(),xsetsymvalue(),xsymplist(),xsetsymplist(),xgensym(),
  30.     xboundp(),xget(),xput(),
  31.     xtheenvironment(),xprocenvironment(),xenvp(),xenvbindings(),xenvparent(),
  32.     xvector(),xmakevector(),xvlength(),xvref(),xvset(),
  33.     xvectlist(),xlistvect(),
  34.     xmakearray(),xaref(),xaset(),
  35.     xsymstr(),xstrsym(),
  36.     xnull(),xatom(),xlistp(),xnumberp(),xbooleanp(),
  37.     xpairp(),xsymbolp(),xintegerp(),xrealp(),xcharp(),xstringp(),xvectorp(),
  38.     xprocedurep(),xobjectp(),xdefaultobjectp(),
  39.     xinputportp(),xoutputportp(),xportp(),
  40.     xeq(),xeqv(),xequal(),
  41.     xzerop(),xpositivep(),xnegativep(),xoddp(),xevenp(),
  42.     xexactp(),xinexactp(),
  43.     xadd1(),xsub1(),xabs(),xgcd(),xrandom(),
  44.     xadd(),xsub(),xmul(),xdiv(),xquo(),xrem(),xmin(),xmax(),
  45.     xsin(),xcos(),xtan(),xasin(),xacos(),xatan(),
  46.     xxexp(),xsqrt(),xexpt(),xxlog(),xtruncate(),xfloor(),xceiling(),xround(),
  47.     xlogand(),xlogior(),xlogxor(),xlognot(),
  48.     xlss(),xleq(),xeql(),xgeq(),xgtr(),
  49.     xstrlen(),xstrnullp(),xstrappend(),xstrref(),xsubstring(),
  50.     xstrlist(),xliststring(),
  51.     xstrlss(),xstrleq(),xstreql(),xstrgeq(),xstrgtr(),
  52.     xstrilss(),xstrileq(),xstrieql(),xstrigeq(),xstrigtr(),
  53.     xcharint(),xintchar(),
  54.     xchrlss(),xchrleq(),xchreql(),xchrgeq(),xchrgtr(),
  55.     xchrilss(),xchrileq(),xchrieql(),xchrigeq(),xchrigtr(),
  56.     xread(),xrdchar(),xrdbyte(),xrdshort(),xrdlong(),xeofobjectp(),
  57.     xwrite(),xwrchar(),xwrbyte(),xwrshort(),xwrlong(),
  58.     xdisplay(),xnewline(),xprint(),xprbreadth(),xprdepth(),
  59.     xopeni(),xopeno(),xopena(),xopenu(),xclosei(),xcloseo(),xclose(),
  60.     xgetfposition(),xsetfposition(),xcurinput(),xcuroutput(),
  61.     xtranson(),xtransoff(),xgetarg(),xexit(),xcompile(),xdecompile(),xgc(),
  62.     xsave(),xrestore(),xtraceon(),xtraceoff(),xreset(),xerror(),
  63.     xicar(),xicdr(),xisetcar(),xisetcdr(),xivlength(),xivref(),xivset();
  64.  
  65. /* include machine specific declarations */
  66. #include "osdefs.h"
  67.  
  68. int xsubrcnt = 12;    /* number of XSUBR functions */
  69. int csubrcnt = 17;    /* number of CSUBR functions + xsubrcnt */
  70.  
  71. typedef LVAL (*FP)();
  72.  
  73. /* built-in functions */
  74. FUNDEF funtab[] = {
  75.  
  76.     /* functions that call eval or apply (# must match xsubrcnt) */
  77. {    "APPLY",                (FP)xapply         },
  78. {    "CALL-WITH-CURRENT-CONTINUATION",    (FP)xcallcc        },
  79. {    "CALL/CC",                (FP)xcallcc        },
  80. {    "MAP",                    (FP)xmap           },
  81. {    "FOR-EACH",                (FP)xforeach    },
  82. {    "CALL-WITH-INPUT-FILE",            (FP)xcallwi      },
  83. {    "CALL-WITH-OUTPUT-FILE",        (FP)xcallwo      },
  84. {    "LOAD",                    (FP)xload        },
  85. {    "LOAD-NOISILY",                (FP)xloadnoisily},
  86. {    "SEND-SUPER",                (FP)xsendsuper    },
  87. {    "%CLASS-NEW",                (FP)clnew          },
  88. {    "FORCE",                (FP)xforce         },
  89.  
  90.     /* continuations for xsubrs (# must match csubrcnt) */
  91. {    "%MAP1",                (FP)xmap1          },
  92. {    "%FOR-EACH1",                (FP)xforeach1    },
  93. {    "%WITH-FILE1",                (FP)xwithfile1    },
  94. {    "%LOAD1",                (FP)xload1         },
  95. {    "%FORCE1",                (FP)xforce1        },
  96.  
  97.     /* methods */
  98. {    "%CLASS-ISNEW",                clisnew        },
  99. {    "%CLASS-ANSWER",            clanswer    },
  100. {    "%OBJECT-ISNEW",            obisnew        },
  101. {    "%OBJECT-CLASS",            obclass        },
  102. {    "%OBJECT-SHOW",                obshow        },
  103.  
  104.     /* list functions */
  105. {    "CONS",                    xcons        },
  106. {    "CAR",                    xcar        },
  107. {    "CDR",                    xcdr        },
  108. {    "CAAR",                    xcaar        },
  109. {    "CADR",                    xcadr        },
  110. {    "CDAR",                    xcdar        },
  111. {    "CDDR",                    xcddr        },
  112. {    "CAAAR",                xcaaar        },
  113. {    "CAADR",                xcaadr        },
  114. {    "CADAR",                xcadar        },
  115. {    "CADDR",                xcaddr        },
  116. {    "CDAAR",                xcdaar        },
  117. {    "CDADR",                xcdadr        },
  118. {    "CDDAR",                xcddar        },
  119. {    "CDDDR",                xcdddr        },
  120. {    "CAAAAR",                 xcaaaar        },
  121. {    "CAAADR",                xcaaadr        },
  122. {    "CAADAR",                xcaadar        },
  123. {    "CAADDR",                xcaaddr        },
  124. {    "CADAAR",                 xcadaar        },
  125. {    "CADADR",                xcadadr        },
  126. {    "CADDAR",                xcaddar        },
  127. {    "CADDDR",                xcadddr        },
  128. {    "CDAAAR",                xcdaaar        },
  129. {    "CDAADR",                xcdaadr        },
  130. {    "CDADAR",                xcdadar        },
  131. {    "CDADDR",                xcdaddr        },
  132. {    "CDDAAR",                xcddaar        },
  133. {    "CDDADR",                xcddadr        },
  134. {    "CDDDAR",                xcdddar        },
  135. {    "CDDDDR",                xcddddr        },
  136. {    "LIST",                    xlist        },
  137. {    "LIST*",                xliststar    },
  138. {    "APPEND",                xappend        },
  139. {    "REVERSE",                xreverse    },
  140. {    "LAST-PAIR",                xlastpair    },
  141. {    "LENGTH",                xlength        },
  142. {    "MEMBER",                xmember        },
  143. {    "MEMV",                    xmemv        },
  144. {    "MEMQ",                    xmemq        },
  145. {    "ASSOC",                xassoc        },
  146. {    "ASSV",                    xassv        },
  147. {    "ASSQ",                    xassq        },
  148. {    "LIST-REF",                xlistref    },
  149. {    "LIST-TAIL",                xlisttail    },
  150.  
  151.     /* destructive list functions */
  152. {    "SET-CAR!",                xsetcar        },
  153. {    "SET-CDR!",                xsetcdr        },
  154.  
  155.  
  156.     /* symbol functions */
  157. {    "BOUND?",                xboundp        },
  158. {    "SYMBOL-VALUE",                xsymvalue    },
  159. {    "SET-SYMBOL-VALUE!",            xsetsymvalue    },
  160. {    "SYMBOL-PLIST",                xsymplist    },
  161. {    "SET-SYMBOL-PLIST!",            xsetsymplist    },
  162. {    "GENSYM",                xgensym        },
  163. {    "GET",                    xget        },
  164. {    "PUT",                    xput        },
  165.  
  166.     /* environment functions */
  167. {    "THE-ENVIRONMENT",            xtheenvironment    },
  168. {    "PROCEDURE-ENVIRONMENT",        xprocenvironment},
  169. {    "ENVIRONMENT?",                xenvp        },
  170. {    "ENVIRONMENT-BINDINGS",            xenvbindings    },
  171. {    "ENVIRONMENT-PARENT",            xenvparent    },
  172.  
  173.     /* vector functions */
  174. {    "VECTOR",                xvector        },
  175. {    "MAKE-VECTOR",                xmakevector    },
  176. {    "VECTOR-LENGTH",            xvlength    },
  177. {    "VECTOR-REF",                xvref        },
  178. {    "VECTOR-SET!",                xvset        },
  179.  
  180.     /* array functions */
  181. {    "MAKE-ARRAY",                xmakearray    },
  182. {    "ARRAY-REF",                xaref        },
  183. {    "ARRAY-SET!",                xaset        },
  184.  
  185.     /* conversion functions */
  186. {    "SYMBOL->STRING",            xsymstr        },
  187. {    "STRING->SYMBOL",            xstrsym        },
  188. {    "VECTOR->LIST",                xvectlist    },
  189. {    "LIST->VECTOR",                xlistvect    },
  190. {    "STRING->LIST",                xstrlist    },
  191. {    "LIST->STRING",                xliststring    },
  192. {    "CHAR->INTEGER",            xcharint    },
  193. {    "INTEGER->CHAR",            xintchar    },
  194.  
  195.     /* predicate functions */
  196. {    "NULL?",                xnull        },
  197. {    "ATOM?",                xatom        },
  198. {    "LIST?",                xlistp        },
  199. {    "NUMBER?",                xnumberp    },
  200. {    "BOOLEAN?",                xbooleanp    },
  201. {    "PAIR?",                xpairp        },
  202. {    "SYMBOL?",                xsymbolp    },
  203. {    "COMPLEX?",                xrealp        }, /*(1)*/
  204. {    "REAL?",                xrealp        },
  205. {    "RATIONAL?",                xintegerp    }, /*(1)*/
  206. {    "INTEGER?",                xintegerp    },
  207. {    "CHAR?",                xcharp        },
  208. {    "STRING?",                xstringp    },
  209. {    "VECTOR?",                xvectorp    },
  210. {    "PROCEDURE?",                xprocedurep    },
  211. {    "PORT?",                xportp        },
  212. {    "INPUT-PORT?",                xinputportp    },
  213. {    "OUTPUT-PORT?",                xoutputportp    },
  214. {    "OBJECT?",                xobjectp    },
  215. {    "EOF-OBJECT?",                xeofobjectp    },
  216. {    "DEFAULT-OBJECT?",            xdefaultobjectp    },
  217. {    "EQ?",                    xeq        },
  218. {    "EQV?",                    xeqv        },
  219. {    "EQUAL?",                xequal        },
  220.  
  221.     /* arithmetic functions */
  222. {    "ZERO?",                xzerop        },
  223. {    "POSITIVE?",                xpositivep    },
  224. {    "NEGATIVE?",                xnegativep    },
  225. {    "ODD?",                    xoddp        },
  226. {    "EVEN?",                xevenp        },
  227. {    "EXACT?",                xexactp        },
  228. {    "INEXACT?",                xinexactp    },
  229. {    "TRUNCATE",                xtruncate    },
  230. {    "FLOOR",                xfloor        },
  231. {    "CEILING",                xceiling    },
  232. {    "ROUND",                xround        },
  233. {    "1+",                    xadd1        },
  234. {    "-1+",                    xsub1        },
  235. {    "ABS",                    xabs        },
  236. {    "GCD",                    xgcd        },
  237. {    "RANDOM",                xrandom        },
  238. {    "+",                    xadd        },
  239. {    "-",                    xsub        },
  240. {    "*",                    xmul        },
  241. {    "/",                    xdiv        },
  242. {    "QUOTIENT",                xquo        },
  243. {    "REMAINDER",                xrem        },
  244. {    "MIN",                    xmin        },
  245. {    "MAX",                    xmax        },
  246. {    "SIN",                    xsin        },
  247. {    "COS",                    xcos        },
  248. {    "TAN",                    xtan        },
  249. {    "ASIN",                    xasin        },
  250. {    "ACOS",                    xacos        },
  251. {    "ATAN",                    xatan        },
  252. {    "EXP",                    xxexp        },
  253. {    "SQRT",                    xsqrt        },
  254. {    "EXPT",                    xexpt        },
  255. {    "LOG",                    xxlog        },
  256.  
  257.     /* bitwise logical functions */
  258. {    "LOGAND",                xlogand        },
  259. {    "LOGIOR",                xlogior        },
  260. {    "LOGXOR",                xlogxor        },
  261. {    "LOGNOT",                xlognot        },
  262.  
  263.     /* numeric comparison functions */
  264. {    "<",                    xlss        },
  265. {    "<=",                    xleq        },
  266. {    "=",                    xeql        },
  267. {    ">=",                    xgeq        },
  268. {    ">",                    xgtr        },
  269.  
  270.     /* string functions */
  271. {    "STRING-LENGTH",            xstrlen        },
  272. {    "STRING-NULL?",                xstrnullp    },
  273. {    "STRING-APPEND",            xstrappend    },
  274. {    "STRING-REF",                xstrref        },
  275. {    "SUBSTRING",                xsubstring    },
  276. {    "STRING<?",                xstrlss        },
  277. {    "STRING<=?",                xstrleq        },
  278. {    "STRING=?",                xstreql        },
  279. {    "STRING>=?",                xstrgeq        },
  280. {    "STRING>?",                xstrgtr        },
  281. {    "STRING-CI<?",                xstrilss    },
  282. {    "STRING-CI<=?",                xstrileq    },
  283. {    "STRING-CI=?",                xstrieql    },
  284. {    "STRING-CI>=?",                xstrigeq    },
  285. {    "STRING-CI>?",                xstrigtr    },
  286.  
  287.     /* character functions */
  288. {    "CHAR<?",                xchrlss        },
  289. {    "CHAR<=?",                xchrleq        },
  290. {    "CHAR=?",                xchreql        },
  291. {    "CHAR>=?",                xchrgeq        },
  292. {    "CHAR>?",                xchrgtr        },
  293. {    "CHAR-CI<?",                xchrilss    },
  294. {    "CHAR-CI<=?",                xchrileq    },
  295. {    "CHAR-CI=?",                xchrieql    },
  296. {    "CHAR-CI>=?",                xchrigeq    },
  297. {    "CHAR-CI>?",                xchrigtr    },
  298.  
  299.     /* I/O functions */
  300. {    "READ",                    xread        },
  301. {    "READ-CHAR",                xrdchar        },
  302. {    "READ-BYTE",                xrdbyte        },
  303. {    "READ-SHORT",                xrdshort    },
  304. {    "READ-LONG",                xrdlong        },
  305. {    "WRITE",                xwrite        },
  306. {    "WRITE-CHAR",                xwrchar        },
  307. {    "WRITE-BYTE",                xwrbyte        },
  308. {    "WRITE-SHORT",                xwrshort    },
  309. {    "WRITE-LONG",                xwrlong        },
  310. {    "DISPLAY",                xdisplay    },
  311. {    "PRINT",                xprint        },
  312. {    "NEWLINE",                xnewline    },
  313.  
  314.     /* print control functions */
  315. {    "PRINT-BREADTH",            xprbreadth    },
  316. {    "PRINT-DEPTH",                xprdepth    },
  317.  
  318.     /* file I/O functions */
  319. {    "OPEN-INPUT-FILE",            xopeni        },
  320. {    "OPEN-OUTPUT-FILE",            xopeno        },
  321. {    "OPEN-APPEND-FILE",            xopena        },
  322. {    "OPEN-UPDATE-FILE",            xopenu        },
  323. {    "CLOSE-PORT",                xclose        },
  324. {    "CLOSE-INPUT-PORT",            xclosei        },
  325. {    "CLOSE-OUTPUT-PORT",            xcloseo        },
  326. {    "GET-FILE-POSITION",            xgetfposition    },
  327. {    "SET-FILE-POSITION!",            xsetfposition    },
  328. {    "CURRENT-INPUT-PORT",            xcurinput    },
  329. {    "CURRENT-OUTPUT-PORT",            xcuroutput    },
  330.  
  331.     /* utility functions */
  332. {    "TRANSCRIPT-ON",            xtranson    },
  333. {    "TRANSCRIPT-OFF",            xtransoff    },
  334. {    "GETARG",                xgetarg        },
  335. {    "EXIT",                    xexit        },
  336. {    "COMPILE",                xcompile    },
  337. {    "DECOMPILE",                xdecompile    },
  338. {    "GC",                    xgc        },
  339. {    "SAVE",                    xsave        },
  340. {    "RESTORE",                xrestore    },
  341. {    "RESET",                xreset        },
  342. {    "ERROR",                xerror        },
  343.  
  344.     /* debugging functions */
  345. {    "TRACE-ON",                xtraceon    },
  346. {    "TRACE-OFF",                xtraceoff    },
  347.  
  348.     /* internal functions */
  349. {    "%CAR",                    xicar        },
  350. {    "%CDR",                    xicdr        },
  351. {    "%SET-CAR!",                xisetcar    },
  352. {    "%SET-CDR!",                xisetcdr    },
  353. {    "%VECTOR-LENGTH",            xivlength    },
  354. {    "%VECTOR-REF",                xivref        },
  355. {    "%VECTOR-SET!",                xivset        },
  356.  
  357. /* include machine specific table entries */
  358. #include "osptrs.h"
  359.  
  360. {0,0} /* end of table marker */
  361.  
  362. };
  363.  
  364. /* Notes:
  365.  
  366.    (1)    This version only supports integers and reals.
  367.  
  368. */
  369.  
  370. /* curinput - get the current input port */
  371. LVAL curinput()
  372. {
  373.     return (getvalue(s_stdin));
  374. }
  375.  
  376. /* curoutput - get the current output port */
  377. LVAL curoutput()
  378. {
  379.     return (getvalue(s_stdout));
  380. }
  381.  
  382. /* eq - internal 'eq?' function */
  383. int eq(arg1,arg2)
  384.   LVAL arg1,arg2;
  385. {
  386.     return (arg1 == arg2);
  387. }
  388.  
  389. /* eqv - internal 'eqv?' function */
  390. int eqv(arg1,arg2)
  391.   LVAL arg1,arg2;
  392. {
  393.     /* try the eq test first */
  394.     if (arg1 == arg2)
  395.     return (TRUE);
  396.  
  397.     /* compare fixnums, flonums and characters */
  398.     if (!null(arg1)) {
  399.     switch (ntype(arg1)) {
  400.     case FIXNUM:
  401.         return (fixp(arg2)
  402.              && getfixnum(arg1) == getfixnum(arg2));
  403.     case FLONUM:
  404.         return (floatp(arg2)
  405.              && getflonum(arg1) == getflonum(arg2));
  406.     case CHAR:
  407.         return (charp(arg2)
  408.              && getchcode(arg1) == getchcode(arg2));
  409.     }
  410.     }
  411.     return (FALSE);
  412. }
  413.  
  414. /* equal - internal 'equal?' function */
  415. int equal(arg1,arg2)
  416.   LVAL arg1,arg2;
  417. {
  418.     /* try the eq test first */
  419.     if (arg1 == arg2)
  420.     return (TRUE);
  421.  
  422.     /* compare fixnums, flonums, characters, strings, vectors and conses */
  423.     if (!null(arg1)) {
  424.     switch (ntype(arg1)) {
  425.     case FIXNUM:
  426.         return (fixp(arg2)
  427.              && getfixnum(arg1) == getfixnum(arg2));
  428.     case FLONUM:
  429.         return (floatp(arg2)
  430.              && getflonum(arg1) == getflonum(arg2));
  431.     case CHAR:
  432.         return (charp(arg2)
  433.              && getchcode(arg1) == getchcode(arg2));
  434.     case STRING:
  435.         return (stringp(arg2)
  436.              && strcmp(getstring(arg1),getstring(arg2)) == 0);
  437.     case VECTOR:
  438.         return (vectorp(arg2)
  439.              && vectorequal(arg1,arg2));
  440.     case CONS:
  441.         return (consp(arg2)
  442.              && equal(car(arg1),car(arg2))
  443.              && equal(cdr(arg1),cdr(arg2)));
  444.     }
  445.     }
  446.     return (FALSE);
  447. }
  448.  
  449. /* vectorequal - compare two vectors */
  450. int vectorequal(v1,v2)
  451.   LVAL v1,v2;
  452. {
  453.     int len,i;
  454.  
  455.     /* compare the vector lengths */
  456.     if ((len = getsize(v1)) != getsize(v2))
  457.     return (FALSE);
  458.  
  459.     /* compare the vector elements */
  460.     for (i = 0; i < len; ++i)
  461.     if (!equal(getelement(v1,i),getelement(v2,i)))
  462.         return (FALSE);
  463.     return (TRUE);
  464. }
  465.  
  466. /* xltoofew - too few arguments to this function */
  467. LVAL xltoofew()
  468. {
  469.     xlfail("too few arguments");
  470.     return (NIL); /* never reached */
  471. }
  472.  
  473. /* xltoomany - too many arguments to this function */
  474. void xltoomany()
  475. {
  476.     xlfail("too many arguments");
  477. }
  478.  
  479. /* xlbadtype - incorrect argument type */
  480. LVAL xlbadtype(val)
  481.   LVAL val;
  482. {
  483.     xlerror("incorrect type",val);
  484.     return (NIL); /* never reached */
  485. }
  486.