home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / xlisp / XLisp 1.7 ƒ / xlisp sources / macfun.c < prev    next >
Encoding:
C/C++ Source or Header  |  1985-12-21  |  7.2 KB  |  375 lines  |  [TEXT/EDIT]
  1. /* macfun.c - macintosh user interface functions for xlisp */
  2.  
  3. #include "xlisp.h"
  4. #include <mem.h>
  5. #include <qd.h>
  6.  
  7. overlay "macstuff"
  8.  
  9. /* external variables */
  10. extern NODE ***xlstack;
  11. extern GrafPtr cwindow,gwindow;
  12.  
  13. /* forward declarations */
  14. FORWARD NODE *do_0();
  15. FORWARD NODE *do_1();
  16. FORWARD NODE *do_2();
  17.  
  18. /* pow - fake power function */
  19. pow()
  20. {
  21.     xlfail("function not available");
  22. }
  23.  
  24. /* xhidepen - hide the pen */
  25. NODE *xhidepen(args)
  26.   NODE *args;
  27. {
  28.     return (do_0(args,'H'));
  29. }
  30.  
  31. /* xshowpen - show the pen */
  32. NODE *xshowpen(args)
  33.   NODE *args;
  34. {
  35.     return (do_0(args,'S'));
  36. }
  37.  
  38. /* xgetpen - get the pen position */
  39. NODE *xgetpen(args)
  40.   NODE *args;
  41. {
  42.     NODE ***oldstk,*val;
  43.     Point p;
  44.     xllastarg(args);
  45.     SetPort(gwindow);
  46.     GetPen(&p);
  47.     SetPort(cwindow);
  48.     oldstk = xlsave(&val,NULL);
  49.     val = consa(NIL);
  50.     rplaca(val,cvfixnum((FIXNUM)p.a.h));
  51.     rplacd(val,cvfixnum((FIXNUM)p.a.v));
  52.     xlstack = oldstk;
  53.     return (val);
  54. }
  55.  
  56. /* xpenmode - set the pen mode */
  57. NODE *xpenmode(args)
  58.   NODE *args;
  59. {
  60.     return (do_1(args,'M'));
  61. }
  62.  
  63. /* xpensize - set the pen size */
  64. NODE *xpensize(args)
  65.   NODE *args;
  66. {
  67.     return (do_2(args,'S'));
  68. }
  69.  
  70. /* xpenpat - set the pen pattern */
  71. NODE *xpenpat(args)
  72.   NODE *args;
  73. {
  74.     NODE *plist;
  75.     char pat[8],i;
  76.     plist = xlmatch(LIST,&args);
  77.     xllastarg(args);
  78.     for (i = 0; i < 8 && consp(plist); ++i, plist = cdr(plist))
  79.     if (fixp(car(plist)))
  80.         pat[i] = car(plist)->n_int;
  81.     SetPort(gwindow);
  82.     PenPat(pat);
  83.     SetPort(cwindow);
  84.     return (NIL);
  85. }
  86.  
  87. /* xpennormal - set the pen to normal */
  88. NODE *xpennormal(args)
  89.   NODE *args;
  90. {
  91.     xllastarg(args);
  92.     SetPort(gwindow);
  93.     PenNormal();
  94.     SetPort(cwindow);
  95.     return (NIL);
  96. }
  97.  
  98. /* xmoveto - Move to a screen location */
  99. NODE *xmoveto(args)
  100.   NODE *args;
  101. {
  102.     return (do_2(args,'m'));
  103. }
  104.  
  105. /* xmove - Move in a specified direction */
  106. NODE *xmove(args)
  107.   NODE *args;
  108. {
  109.     return (do_2(args,'M'));
  110. }
  111.  
  112. /* xlineto - draw a Line to a screen location */
  113. NODE *xlineto(args)
  114.   NODE *args;
  115. {
  116.     return (do_2(args,'l'));
  117. }
  118.  
  119. /* xline - draw a Line in a specified direction */
  120. NODE *xline(args)
  121.   NODE *args;
  122. {
  123.     return (do_2(args,'L'));
  124. }
  125.  
  126. /* xshowgraphics - show the graphics window */
  127. NODE *xshowgraphics(args)
  128.   NODE *args;
  129. {
  130.     xllastarg(args);
  131.     scrsplit(1);
  132.     return (NIL);
  133. }
  134.  
  135. /* xhidegraphics - hide the graphics window */
  136. NODE *xhidegraphics(args)
  137.   NODE *args;
  138. {
  139.     xllastarg(args);
  140.     scrsplit(0);
  141.     return (NIL);
  142. }
  143.  
  144. /* xcleargraphics - clear the graphics window */
  145. NODE *xcleargraphics(args)
  146.   NODE *args;
  147. {
  148.     xllastarg(args);
  149.     SetPort(gwindow);
  150.     EraseRect(&gwindow->portRect);
  151.     SetPort(cwindow);
  152.     return (NIL);
  153. }
  154.  
  155. /* do_0 - Handle commands that require no arguments */
  156. LOCAL NODE *do_0(args,fcn)
  157.   NODE *args; int fcn;
  158. {
  159.     xllastarg(args);
  160.     SetPort(gwindow);
  161.     switch (fcn) {
  162.     case 'H':    HidePen(); break;
  163.     case 'S':    ShowPen(); break;
  164.     }
  165.     SetPort(cwindow);
  166.     return (NIL);
  167. }
  168.  
  169. /* do_1 - Handle commands that require one integer argument */
  170. LOCAL NODE *do_1(args,fcn)
  171.   NODE *args; int fcn;
  172. {
  173.     int x;
  174.     x = getnumber(&args);
  175.     xllastarg(args);
  176.     SetPort(gwindow);
  177.     switch (fcn) {
  178.     case 'M':    PenMode(x); break;
  179.     }
  180.     SetPort(cwindow);
  181.     return (NIL);
  182. }
  183.  
  184. /* do_2 - Handle commands that require two integer arguments */
  185. LOCAL NODE *do_2(args,fcn)
  186.   NODE *args; int fcn;
  187. {
  188.     int h,v;
  189.     h = getnumber(&args);
  190.     v = getnumber(&args);
  191.     xllastarg(args);
  192.     SetPort(gwindow);
  193.     switch (fcn) {
  194.     case 'l':    LineTo(h,v); break;
  195.     case 'L':    Line(h,v);   break;
  196.     case 'm':   MoveTo(h,v); break;
  197.     case 'M':    Move(h,v);   break;
  198.     case 'S':    PenSize(h,v);break;
  199.     }
  200.     SetPort(cwindow);
  201.     return (NIL);
  202. }
  203.  
  204. /* getnumber - get an integer parameter */
  205. LOCAL int getnumber(pargs)
  206.   NODE **pargs;
  207. {
  208.     return ((int)xlmatch(INT,pargs)->n_int);
  209. }
  210.  
  211. /* xtool - call the toolbox */
  212. NODE *xtool(args)
  213.   NODE *args;
  214. {
  215.     NODE *val;
  216.     int trap;
  217.  
  218.     trap = (int)xlmatch(INT,&args)->n_int;
  219.  
  220.     asm {
  221.     move.l    args(A6),D0
  222.     beq    L2
  223. L1:    move.l    D0,A0
  224.     move.l    2(A0),A1
  225.     move.w    4(A1),-(A7)
  226.     move.l    6(A0),D0
  227.     bne    L1
  228. L2:    lea    L3,A0
  229.     move.w    trap(A6),(A0)
  230. L3:    dc.w    0xA000
  231.     clr.l    val(A6)
  232.     }
  233.  
  234.     return (val);
  235. }
  236.  
  237. /* xtool16 - call the toolbox with a 16 bit result */
  238. NODE *xtool16(args)
  239.   NODE *args;
  240. {
  241.     int trap,val;
  242.  
  243.     trap = xlmatch(INT,&args)->n_int;
  244.  
  245.     asm {
  246.     clr.w    -(A7)
  247.     move.l    args(A6),D0
  248.     beq    L2
  249. L1:    move.l    D0,A0
  250.     move.l    2(A0),A1
  251.     move.w    4(A1),-(A7)
  252.     move.l    6(A0),D0
  253.     bne    L1
  254. L2:    lea    L3,A0
  255.     move.w    trap(A6),(A0)
  256. L3:    dc.w    0xA000
  257.     move.w    (A7)+,val(A6)
  258.     }
  259.  
  260.     return (cvfixnum((FIXNUM)val));
  261. }
  262.  
  263. /* xtool32 - call the toolbox with a 32 bit result */
  264. NODE *xtool32(args)
  265.   NODE *args;
  266. {
  267.     int trap;
  268.     long val;
  269.  
  270.     trap = xlmatch(INT,&args)->n_int;
  271.  
  272.     asm {
  273.     clr.l    -(A7)
  274.     move.l    args(A6),D0
  275.     beq    L2
  276. L1:    move.l    D0,A0
  277.     move.l    2(A0),A1
  278.     move.w    4(A1),-(A7)
  279.     move.l    6(A0),D0
  280.     bne    L1
  281. L2:    lea    L3,A0
  282.     move.w    trap(A6),(A0)
  283. L3:    dc.w    0xA000
  284.     move.l    (A7)+,val(A6)
  285.     }
  286.  
  287.     return (cvfixnum((FIXNUM)val));
  288. }
  289.  
  290. /* xnewhandle - allocate a new handle */
  291. NODE *xnewhandle(args)
  292.   NODE *args;
  293. {
  294.     long size;
  295.     size = (long)xlmatch(INT,&args)->n_int;
  296.     xllastarg(args);
  297.     return (cvfixnum((FIXNUM)NewHandle(size)));
  298. }
  299.  
  300. /* xnewptr - allocate memory */
  301. NODE *xnewptr(args)
  302.   NODE *args;
  303. {
  304.     long size;
  305.     size = (long)xlmatch(INT,&args)->n_int;
  306.     xllastarg(args);
  307.     return (cvfixnum((FIXNUM)NewPtr(size)));
  308. }
  309.     
  310. /* xhiword - return the high order 16 bits of an integer */
  311. NODE *xhiword(args)
  312.   NODE *args;
  313. {
  314.     unsigned int val;
  315.     val = (unsigned int)(xlmatch(INT,&args)->n_int >> 16);
  316.     xllastarg(args);
  317.     return (cvfixnum((FIXNUM)val));
  318. }
  319.  
  320. /* xloword - return the low order 16 bits of an integer */
  321. NODE *xloword(args)
  322.   NODE *args;
  323. {
  324.     unsigned int val;
  325.     val = (unsigned int)xlmatch(INT,&args)->n_int;
  326.     xllastarg(args);
  327.     return (cvfixnum((FIXNUM)val));
  328. }
  329.  
  330. /* xrdnohang - get the next character in the look-ahead buffer */
  331. NODE *xrdnohang(args)
  332.   NODE *args;
  333. {
  334.     int ch;
  335.     xllastarg(args);
  336.     if ((ch = scrnextc()) == EOF)
  337.     return (NIL);
  338.     return (cvfixnum((FIXNUM)ch));
  339. }
  340.  
  341. /* osfinit - initialize the macintosh functions */
  342. osfinit()
  343. {
  344.     NODE *sym;
  345.  
  346.     xlsubr("HIDEPEN",        SUBR,    xhidepen);
  347.     xlsubr("SHOWPEN",        SUBR,    xshowpen);
  348.     xlsubr("GETPEN",        SUBR,    xgetpen);
  349.     xlsubr("PENSIZE",        SUBR,    xpensize);
  350.     xlsubr("PENMODE",        SUBR,    xpenmode);
  351.     xlsubr("PENPAT",        SUBR,    xpenpat);
  352.     xlsubr("PENNORMAL",        SUBR,    xpennormal);
  353.     xlsubr("MOVETO",        SUBR,    xmoveto);
  354.     xlsubr("MOVE",        SUBR,    xmove);
  355.     xlsubr("LINETO",        SUBR,    xlineto);
  356.     xlsubr("LINE",        SUBR,    xline);
  357.     xlsubr("SHOW-GRAPHICS",    SUBR,    xshowgraphics);
  358.     xlsubr("HIDE-GRAPHICS",    SUBR,    xhidegraphics);
  359.     xlsubr("CLEAR-GRAPHICS",    SUBR,    xcleargraphics);
  360.     xlsubr("TOOLBOX",        SUBR,    xtool);
  361.     xlsubr("TOOLBOX-16",    SUBR,    xtool16);
  362.     xlsubr("TOOLBOX-32",    SUBR,    xtool32);
  363.     xlsubr("NEWHANDLE",        SUBR,    xnewhandle);
  364.     xlsubr("NEWPTR",        SUBR,    xnewptr);
  365.     xlsubr("HIWORD",        SUBR,    xhiword);
  366.     xlsubr("LOWORD",        SUBR,    xloword);
  367.     xlsubr("READ-CHAR-NO-HANG",    SUBR,    xrdnohang);
  368.  
  369.     /* setup globals for the window handles */
  370.     sym = xlsenter("*COMMAND-WINDOW*");
  371.     sym->n_symvalue = cvfixnum((FIXNUM)cwindow);
  372.     sym = xlsenter("*GRAPHICS-WINDOW*");
  373.     sym->n_symvalue = cvfixnum((FIXNUM)gwindow);
  374. }
  375.