home *** CD-ROM | disk | FTP | other *** search
/ Super Net 1 / SUPERNET_1.iso / PC / OTROS / MSDOS / WATTCP / DELFT / SAGE.TAR / sage / scheme / schprc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-04-26  |  14.5 KB  |  443 lines
  1. /**********************************************************************
  2. ** MODULE INFORMATION*
  3. **********************
  4. **      FILE     NAME:       SCHPRC.C
  5. **      SYSTEM   NAME:       SCHEME
  6. **      ORIGINAL AUTHOR(S):  Alfred Kayser
  7. **      VERSION  NUMBER:     1.5.5
  8. **      CREATION DATE:       88/12/02
  9. **                                                                  
  10. ** DESCRIPTION: Contains all the LISP functions as defined by
  11. **              the SCHEME system.
  12. **              The functions starting with Ds_ are kernel functions
  13. **              These are essential functions of the SCHEME system.
  14. ***********************************************************************
  15. ** CHANGES INFORMATION **
  16. *************************
  17. ** REVISION:    $Revision:   1.0  $
  18. ** CHANGER:     $Author:   JAN  $
  19. ** WORKFILE:    $Workfile:   schprc.c  $
  20. ** LOGFILE:     $Logfile:   C:/CPROG/SCHEME/VCS/SCHPRC.C_V  $
  21. ** LOGINFO:     $Log:   C:/CPROG/SCHEME/VCS/SCHPRC.C_V  $
  22. **              
  23. **                 Rev 1.0   12 Oct 1989 11:46:10   JAN
  24. **              Initial revision.
  25. **********************************************************************/
  26. #include "schinc.h"
  27. #include "schdef.h"
  28.  
  29.  
  30. /***************************************************************
  31. ** NAME:        DsCompare
  32. ** SYNOPSIS:    CELP DsCompare(a1,a2)
  33. **              CELP a1,a2;     The two arguments to DsCompare
  34. ** DESCRIPTION: Compares the values of two cel pointers.
  35. ** RETURNS:     NIL when they are different, Q_true otherwise
  36. ** SEE ALSO:    DsEq, DsEqv, DsEqual.
  37. ***************************************************************/
  38. CELP PASCAL DsCompare(a1,a2)
  39. CELP a1,a2;
  40. {
  41.     switch(TAG(a1))
  42.     {
  43.     case TYPE_NIL : RETBOO(ISNIL(a2)); 
  44.     case TYPE_MAC :
  45.     case TYPE_EXT : 
  46.     case TYPE_SPC :
  47.     case TYPE_KEY :
  48.     case TYPE_SYM : RETBOO(a1==a2);
  49.     case TYPE_BIGP:
  50.     case TYPE_BIGN:
  51.     case TYPE_INT :
  52.     case TYPE_FLT : return DsCmpNumber(a1,a2,0);
  53.     case TYPE_TMS : RETBOO(CELTIM(a1).time == CELTIM(a2).time &&
  54.                            CELTIM(a1).date == CELTIM(a2).date &&
  55.                            CELTIM(a1).fsec == CELTIM(a2).fsec);
  56.     case TYPE_CHR : RETBOO(CELCHR(a1)==CELCHR(a2));
  57.     case TYPE_PRT : RETBOO(CELPRT(a1)==CELPRT(a2));
  58.     case TYPE_STR : RETBOO(strcmp(STRPpart(a1),STRPpart(a2))==0);
  59.     case TYPE_OID : RETBOO(INTpart(a1)==INTpart(a2));
  60.     case TYPE_VEC : return DsCmpVector(a1,a2);
  61.     }
  62.     DSVERROR(ERRUNT);
  63. }
  64.  
  65.  
  66. /***************************************************************
  67. ** NAME:        DsEqv
  68. ** SYNOPSIS:    CELP DsEqv(a1,a2)
  69. **              CELP a1,a2;     The two arguments to DsCompare
  70. ** DESCRIPTION: Compares two cel pointers and when they are
  71. **              different it DsCompares the values of the cells.
  72. **              When a1 and a2 are pointers to pairs, the car
  73. **              and cdr pointers are DsCompared.
  74. ** RETURNS:     NIL when they are different, Q_true otherwise
  75. ** SEE ALSO:    DsEq, DsEqual.
  76. ***************************************************************/
  77. CELP PASCAL DsEqv(a1,a2)
  78. CELP a1,a2;
  79. {
  80.     if (a1==a2) return(Q_true);  /* ok */
  81.  
  82.     if (ISFALS(a1) || ISFALS(a2)) return(Q_false); /* not ok */
  83.     if (TAGpart(a1)!=TAGpart(a2)) return(Q_false);
  84.     if (_ISCAR(a1))
  85.         RETBOO(CARpart(a1)==CARpart(a2) && CDRpart(a1)==CDRpart(a2));
  86.     else
  87.         return(DsCompare(a1,a2));
  88. }
  89.  
  90.  
  91. /***************************************************************
  92. ** NAME:        DsEqual
  93. ** SYNOPSIS:    CELP DsEqual(a1,a2)
  94. **              CELP a1,a2;     The two arguments to DsCompare
  95. ** DESCRIPTION: Compares two cel pointers and when they are
  96. **              different it DsCompares the values of the cells.
  97. **              When a1 and a2 are pointers to pairs, the car
  98. **              and cdr are tested with DsEqual (recursively!).
  99. ** RETURNS:     NIL when they are different, Q_true otherwise
  100. ** SEE ALSO:    DsEqv, DsEq.
  101. ***************************************************************/
  102. CELP PASCAL DsEqual(a1,a2)
  103. CELP a1,a2;
  104. {
  105.     if (a1==a2) return(Q_true);  /* ok */
  106.     if (ISFALS(a1) || ISFALS(a2)) return(Q_false); /* not ok */
  107.     if (TAGpart(a1)!=TAGpart(a2)) return(Q_false);
  108.     if (_ISCAR(a1))
  109.          RETBOO( ISTRUE(DsEqual(CARpart(a1),CARpart(a2))) &&
  110.                  ISTRUE(DsEqual(CDRpart(a1),CDRpart(a2))) );
  111.     else
  112.         return(DsCompare(a1,a2));
  113. }
  114.  
  115.  
  116. /***************************************************************
  117. ** NAME:        DsCmpTime
  118. ** SYNOPSIS:    CELP DsCmpTime(a1,a2,t)
  119. **              CELP a1,a2;     The two timestamps to DsCompare
  120. **              int  t;         type test;
  121. ** DESCRIPTION: Compares two timestamps
  122. **              Timestamp is an extention to the standard Scheme
  123. **              t=0: test on DsEqual
  124. **              t=1: test on greater or DsEqual
  125. **              t=2: test on greator than
  126. ** RETURNS:     NIL when they are different, Q_true otherwise
  127. ***************************************************************/
  128. CELP PASCAL DsCmpTime(a1,a2,t)
  129. CELP a1,a2;
  130. int t;
  131. {
  132.     TYPCHECK(a1,TYPE_TMS);
  133.     TYPCHECK(a2,TYPE_TMS);
  134.     if (t==0)   
  135.         RETBOO(CELTIM(a1).time == CELTIM(a2).time &&
  136.                CELTIM(a1).date == CELTIM(a2).date &&
  137.                CELTIM(a1).fsec == CELTIM(a2).fsec);
  138.     else
  139.     {
  140.         if (CELTIM(a1).date!=CELTIM(a2).date)
  141.             RETBOO(CELTIM(a1).date > CELTIM(a2).date);      /* date is bigger */
  142.         if (CELTIM(a1).time!=CELTIM(a2).time)
  143.             RETBOO(CELTIM(a1).time > CELTIM(a2).time);      /* time is bigger */
  144.         if (t==1)                                            /* less or equal */
  145.             RETBOO(CELTIM(a1).fsec >= CELTIM(a2).fsec);
  146.         else                                                     /* less than */
  147.             RETBOO(CELTIM(a1).fsec > CELTIM(a2).fsec);
  148.     }
  149. }
  150.  
  151.  
  152. /***************************************************************
  153. ** NAME:        DsCmpChar
  154. ** SYNOPSIS:    CELP DsCmpChar(a1,a2,t)
  155. **              CELP a1,a2;     The two chars to compare
  156. **              int  t;         type test;
  157. ** DESCRIPTION: Compares two characters.
  158. **              t=0: test on equal
  159. **              t=1: test on greater or equal
  160. **              t=2: test on greator than
  161. ** RETURNS:     NIL when they are different, Q_true otherwise
  162. ***************************************************************/
  163. CELP PASCAL DsCmpChar(a1,a2,t)
  164. CELP a1,a2;
  165. int t;
  166. {
  167.     TYPCHECK(a1,TYPE_CHR);
  168.     TYPCHECK(a2,TYPE_CHR);
  169.     switch(t)
  170.     {
  171.     case 0: RETBOO(CHRpart(a1) == CHRpart(a2));
  172.     case 1: RETBOO(CHRpart(a1) >= CHRpart(a2));
  173.     case 2: RETBOO(CHRpart(a1) > CHRpart(a2));
  174.     case 3: RETBOO(tolower(CHRpart(a1)) == tolower(CHRpart(a2)));
  175.     case 4: RETBOO(tolower(CHRpart(a1)) >= tolower(CHRpart(a2)));
  176.     case 5: RETBOO(tolower(CHRpart(a1)) >  tolower(CHRpart(a2)));
  177.     }
  178.     return NIL;
  179. }
  180.  
  181.  
  182. /***************************************************************
  183. ** NAME:        DsAssQ
  184. ** SYNOPSIS:    void DsAssQ(key,list)
  185. **              CELP key;       Key to search for
  186. **              CELP list;      List to search in
  187. ** DESCRIPTION: Finds item in list whose car is same (DsEq)
  188. **              as key and returns it.
  189. ** RETURNS:     NIL when item is not found, item otherwise.
  190. ** SEE ALSO:    DsEq
  191. ***************************************************************/
  192. CELP PASCAL DsAssQ(key,list)
  193. CELP key,list;     
  194. {
  195.     for (;ISTRUE(list);list=CDRpart(list))
  196.         if (key==DsCaar(list))
  197.             return CARpart(list);
  198.     return NIL;
  199. }
  200.  
  201.  
  202. /***************************************************************
  203. ** NAME:        DsAssV
  204. ** SYNOPSIS:    void DsAssV(key,list)
  205. **              CELP key;       Key to search for
  206. **              CELP list;      List to search in
  207. ** DESCRIPTION: Finds item in list whose car is same (DsEqv)
  208. **              as key and returns it.
  209. ** RETURNS:     NILL when item is not found, item otherwise.
  210. ** SEE ALSO:    DsEqv
  211. ***************************************************************/
  212. CELP PASCAL DsAssV(key,list)
  213. CELP key,list;
  214. {
  215.     for (;ISTRUE(list);list=CDRpart(list))
  216.         if (ISTRUE(DsEqv(key,DsCaar(list))))
  217.             return CARpart(list);
  218.     return Q_false;
  219. }
  220.  
  221.  
  222. /***************************************************************
  223. ** NAME:        DsAssoc
  224. ** SYNOPSIS:    void DsAssoc(key,list)
  225. **              CELP key;       Key to search for
  226. **              CELP list;      List to search in
  227. ** DESCRIPTION: Finds item in list whose car is same (DsEqual)
  228. **              as key and returns it.
  229. ** RETURNS:     Q_false when item is not found, item otherwise.
  230. ** SEE ALSO:    DsEqual
  231. ***************************************************************/
  232. CELP PASCAL DsAssoc(key,list)
  233. CELP key,list;
  234. {
  235.     for (;ISTRUE(list);list=CDRpart(list))
  236.         if (ISTRUE(DsEqual(key,DsCaar(list))))
  237.             return CARpart(list);
  238.     return Q_false;
  239. }
  240.  
  241.  
  242. /***************************************************************
  243. ** NAME:        DsMemQ
  244. ** SYNOPSIS:    CELP DsMemQ(key,list)
  245. **              CELP key;       Key to search for
  246. **              CELP list;      List to search in
  247. ** DESCRIPTION: Tests if key is somewhere in the list.
  248. ** RETURNS:     Q_false when item is not found.
  249. **              pointer to list starting with key otherwise.
  250. ** SEE ALSO:    DsEq
  251. ***************************************************************/
  252. CELP PASCAL DsMemQ(key,list)
  253. CELP key,list;
  254. {
  255.     for (;ISTRUE(list);list=CDRpart(list))
  256.         if (key==DsCar(list))
  257.             return list;
  258.     return Q_false;
  259. }
  260.  
  261.  
  262. /***************************************************************
  263. ** NAME:        DsMemV
  264. ** SYNOPSIS:    CELP DsMemV(key,list)
  265. **              CELP key;       Key to search for
  266. **              CELP list;      List to search in
  267. ** DESCRIPTION: Tests if key is somewhere in the list.
  268. ** RETURNS:     Q_false when item is not found.
  269. **              pointer to list starting with key otherwise.
  270. ** SEE ALSO:    DsEqv
  271. ***************************************************************/
  272. #undef  FUNCTION
  273. #define FUNCTION "DsMemV"
  274.  
  275. CELP PASCAL DsMemV(key,list)
  276. CELP key,list;
  277. {
  278.     for (;ISTRUE(list);list=CDRpart(list))
  279.         if (ISTRUE(DsEqv(key,DsCar(list))))
  280.             return list;
  281.     return Q_false;
  282. }
  283.  
  284.  
  285. /***************************************************************
  286. ** NAME:        DsMember
  287. ** SYNOPSIS:    CELP DsMember(key,list)
  288. **              CELP key;       Key to search for
  289. **              CELP list;      List to search in
  290. ** DESCRIPTION: Tests if key is somewhere in the list.
  291. ** RETURNS:     Q_false when item is not found.
  292. **              pointer to list starting with key otherwise.
  293. ** SEE ALSO:    DsEqual
  294. ***************************************************************/
  295. CELP PASCAL DsMember(key,list)
  296. CELP key,list;
  297. {
  298.     for (;ISTRUE(list);list=CDRpart(list))
  299.         if (ISTRUE(DsEqual(key,DsCar(list)))) 
  300.             return list;
  301.     return Q_false;
  302. }
  303.      
  304.  
  305. /***************************************************************
  306. ** NAME:        DsLength
  307. ** SYNOPSIS:    LONG DsLength(list)
  308. **              CELP list;      List
  309. ** DESCRIPTION: Calculates the length of the list
  310. ** RETURNS:     The length.
  311. ***************************************************************/
  312. LONG PASCAL DsLength(l)
  313. CELP l;
  314. {
  315.     register LONG t=0;
  316.     for (;ISCDR(l);l=CDRpart(l)) t++; /* count each element of the list */
  317.     return(t);
  318. }
  319.  
  320.  
  321. /***************************************************************
  322. ** NAME:        Ds_load
  323. ** SYNOPSIS:    CELP Ds_load(l)
  324. **              CELP l;         Pointer to cell with filename
  325. ** DESCRIPTION: Opens the file (on S.stack) in READMODE and
  326. **              redirects inport to the new port until the EOF
  327. **              is found. This results into the 'loading' of
  328. **              a file of scheme commands.
  329. ** RETURNS:     TRUE, when open succeeds.
  330. ***************************************************************/
  331. CELP Ds_load(name)
  332. CELP name;
  333. {
  334.     PORT *newp;
  335.     CELP exp;
  336.  
  337.     if ((newp=DsFOpen(STRPpart(name),READMODE))==NIL)
  338.         return(Q_false);                                   /* file not found! */
  339.     while ((exp=DsRead(newp))!=Q_eof)
  340.         DsEval(exp);
  341.     DsClosePort(newp);                                     /* end of old port */
  342.     return(Q_invis);                                        /* end of loading */
  343. }
  344.  
  345.  
  346. /***************************************************************
  347. ** NAME:        Ds_math1
  348. ** SYNOPSIS:    CELP Ds_math1(opcode,arg)
  349. **              int opcode;     Nr of operation
  350. **              CELP arg;       Argument
  351. ** DESCRIPTION: Performs all unary operations.
  352. **              It switches first on argument type, and performs
  353. **              then the operation.
  354. ** RETURNS:     the answer.
  355. ***************************************************************/
  356. CELP PASCAL Ds_math1(opcode,arg)
  357. int opcode;
  358. CELP arg;
  359. {
  360.     if (ISNIL(arg))
  361.         RETBOO(opcode==IP_ISBOOL);
  362.     if (opcode==IP_ISATOM && TAGpart(arg)!=TYPE_PAIR)
  363.         return Q_true;
  364.     switch(TAGpart(arg))
  365.     {
  366.     case TYPE_INT:
  367.         if ( opcode==IP_ISINT
  368.             || opcode==IP_ISNUMBER) return Q_true;
  369.         break;
  370.  
  371.     case TYPE_FLT:
  372.         if ( opcode==IP_ISREAL
  373.             || opcode==IP_ISNUMBER) return Q_true;
  374.         break;
  375.  
  376.     case TYPE_TMS:
  377.         if (opcode==IP_ISTIME) return Q_true;
  378.         break;
  379.  
  380.     case TYPE_PAIR:
  381.         switch(opcode)
  382.         {
  383.         case IP_ISLIST  :if ISPAIR(CDRpart(arg)) return Q_true;
  384.         case IP_ISPAIR  :return Q_true;
  385.         }
  386.         break;
  387.  
  388.     case TYPE_PRT:
  389.         switch(opcode)
  390.         {
  391.         case IP_ISIPORT :if (CELPRT(arg)->dir & READMODE) return Q_true;
  392.         case IP_ISOPORT :if (CELPRT(arg)->dir & WRITMODE) return Q_true;
  393.         case IP_ISPORT  :return Q_true;
  394.         }
  395.         break;
  396.  
  397.     case TYPE_CHR:
  398.         switch(opcode)
  399.         {
  400.         case IP_ISCHAR:    return Q_true;
  401.         case IP_ISCHALPHA: if (isalpha(CHRpart(arg))) return Q_true;break;
  402.         case IP_ISCHNUMER: if (isdigit(CHRpart(arg))) return Q_true;break;
  403.         case IP_ISCHWHITE: if (isspace(CHRpart(arg))) return Q_true;break;
  404.         case IP_ISCHUPERR: if (isupper(CHRpart(arg))) return Q_true;break;
  405.         case IP_ISCHLOWER: if (islower(CHRpart(arg))) return Q_true;break;
  406.         }
  407.         break;
  408.  
  409.     case TYPE_STR:
  410.         if (opcode==IP_ISSTR) return Q_true;        
  411.         break;
  412.  
  413.     case TYPE_BIGN:
  414.     case TYPE_BIGP:
  415.         if  ( opcode==IP_ISBIGNUM
  416.             || opcode==IP_ISINT
  417.             || opcode==IP_ISNUMBER) return Q_true;
  418.         break;
  419.  
  420.     case TYPE_PRC:
  421.         if (opcode==IP_ISPROC) return Q_true;
  422.         break;
  423.  
  424.     case TYPE_SYM:
  425.         if (opcode==IP_ISSYM) return Q_true;
  426.         break;
  427.  
  428.     case TYPE_VEC:
  429.         if (opcode==IP_ISVECTOR) return Q_true;
  430.         break;
  431.  
  432.     default:
  433.         switch(opcode)
  434.         {
  435.         case IP_ISBOOL:if (arg==Q_true) return Q_true;
  436.         case IP_ISEOF :if (arg==Q_eof) return Q_true;
  437.         }
  438.     }
  439.     return Q_false;
  440. }
  441.  
  442.  
  443.