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