home *** CD-ROM | disk | FTP | other *** search
/ MacGames Sampler / PHT MacGames Bundle.iso / MacSource Folder / Samples from the CD / Editors / emacs / Emacs-1.14b1-sources / sources / mac-emacs-src / toolbox.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-05-31  |  21.4 KB  |  721 lines  |  [TEXT/EMAC]
  1. /*
  2.  * Copyright (C) 1993, 1994 Marc Parmet.
  3.  * This file is part of the Macintosh port of GNU Emacs.
  4.  *
  5.  * GNU Emacs is distributed in the hope that it will be useful,
  6.  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  7.  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  8.  * GNU General Public License for more details.
  9.  */
  10.  
  11. #if defined(THINK_C)
  12. #include <MacHeaders>
  13. #else
  14. #include <Types.h>
  15. #include <Memory.h>
  16. #include <Quickdraw.h>
  17. #include <Windows.h>
  18. #include <Dialogs.h>
  19. #include <Errors.h>
  20. #include <ToolUtils.h>
  21. #endif
  22.  
  23. #include <AppleEvents.h>
  24. #include <AEPackObject.h>
  25. #include "signal.h"
  26. #include "config.h"
  27. #include "lisp.h"
  28. #include "buffer.h"
  29. #include "window.h"
  30. #include "termchar.h"
  31. #include "68k-traps.h"
  32.  
  33. // This is so that we can document functions without having to remake the DOC file.
  34. #undef DEFUN
  35. #define DEFUN(lname, fnname, sname, minargs, maxargs, prompt, doc) \
  36.   Lisp_Object fnname (); \
  37.   struct Lisp_Subr sname = {fnname, minargs, maxargs, lname, prompt, doc }; \
  38.   Lisp_Object fnname
  39.  
  40. WindowPtr console_window(),tty_window();
  41. WCTabHandle console_WCTabHandle();
  42.  
  43. Lisp_Object Vmodifier_vector = 0;
  44. Lisp_Object Vaccept_high_level_events;
  45. Lisp_Object Vquit_in_main_event_loop;
  46. Lisp_Object Vmin_stack_size;
  47. Lisp_Object Vpowerc;
  48.  
  49. Lisp_Object Vmac_trap_code,Vmac_trap_code_end,Vmac_trap_code_max;
  50.  
  51. static Lisp_Object Qchar,Qshort,Qlong,Qunsigned_char,Qunsigned_short,Qunsigned_long,
  52.     Qverbatim_long,Qstring,Qpascal_string;
  53.  
  54. static int min(a,b) { return a<b ? a : b; }
  55.  
  56. int
  57. string_to_restype(struct Lisp_String *s)
  58. {
  59.     int i,len,type;
  60.  
  61.     len = s->size;
  62.     type = 0;
  63.     for (i = 0; i<min(len,4); ++i)
  64.         type |= s->data[i] << ((3-i) * 8);
  65.         
  66.     return type;
  67. }
  68.  
  69. static Lisp_Object internal_cmd;
  70.  
  71. static Lisp_Object
  72. pass_up_lisp_command1(void)
  73. {
  74.     return Feval(internal_cmd);
  75. }
  76.  
  77. Lisp_Object
  78. pass_up_lisp_command(Lisp_Object cmd)
  79. {
  80.     struct gcpro gcpro1;
  81.     extern Lisp_Object cmd_error();
  82.     extern int waiting_for_input; // Fsignal checks this -- I don't know why
  83.     int old_waiting_for_input;
  84.     Lisp_Object result;
  85.  
  86.     internal_cmd = cmd;
  87.     GCPRO1(internal_cmd);
  88.     old_waiting_for_input = waiting_for_input;
  89.     waiting_for_input = 0;
  90.     result = internal_condition_case(pass_up_lisp_command1,Qerror,cmd_error);
  91.     waiting_for_input = old_waiting_for_input;
  92.     UNGCPRO;
  93.     return result;
  94. }
  95.  
  96. pascal short
  97. ae_receive_func2(AppleEvent *e_ci,AppleEvent *reply_ci,long refCon)
  98. {
  99.     Lisp_Object func,err,e_li,reply_li,refCon_li;
  100.  
  101.     // Be careful not to evaluate the refCon twice.  It was already evaluated once.
  102.     func = Fcons(intern("ae-receive"),
  103.                  Fcons(XSET(e_li,Lisp_Int,e_ci),
  104.                        Fcons(XSET(reply_li,Lisp_Int,reply_ci),
  105.                              Fcons(Fcons(Qquote,Fcons(refCon,Qnil)),
  106.                                          Qnil))));
  107.     err = pass_up_lisp_command(func);
  108.     return XINT(err);
  109. }
  110.  
  111. DEFUN("string-data",Fstring_data,Sstring_data,
  112.       1,1,0,"Return as an integer the address of the data of STRING.")
  113. (s)
  114. {
  115.     Lisp_Object result;
  116.     CHECK_STRING(s,0);
  117.     return XSET(result,Lisp_Int,(unsigned long)XSTRING(s)->data);
  118. }
  119.  
  120. DEFUN("extract-internal",Fextract_internal,Sextract_internal,
  121.       3,4,0,
  122.       "Extract from STRING, starting at byte INDEX, an integer according\012"
  123.       "to TYPE.  If TYPE is 'char, the byte at the given address is sign\012"
  124.       "extended to a lisp integer, which is returned.  If TYPE is\012"
  125.       "'unsigned-char, the byte is zero extended.  If TYPE is 'short or\012"
  126.       "'unsigned-short, the word, either sign or zero extended, is returned.\012"
  127.       "If TYPE is 'long or 'unsigned-long, the long word at the given address\012"
  128.       "is returned, with a loss of some high bits.  If TYPE is 'verbatim-long,\012"
  129.       "the long word is returned verbatim, high bits included.  If TYPE is 'string,\012"
  130.       "then a string of a fourth parameter LENGTH bytes is extracted.  If\012"
  131.       "TYPE is 'pascal-string, then a pascal style string is extracted.\012"
  132.       "STRING can also be an integer, which is interpreted as an address.")
  133. (string_lo,index_li,type_ls,length_li)
  134. {
  135.     int index_ci;
  136.     unsigned char *base;
  137.     Lisp_Object t;
  138.  
  139.     CHECK_NUMBER(index_li,1);
  140.     CHECK_SYMBOL(type_ls,2);
  141.     index_ci = XINT(index_li);
  142.  
  143.     if (XTYPE(string_lo) == Lisp_String) {
  144.         struct Lisp_String *string_ls = XSTRING(string_lo);
  145.         if (index_ci < 0 || index_ci >= string_ls->size) return Qnil;
  146.         base = string_ls->data;
  147.     }
  148.     else if (XTYPE(string_lo) == Lisp_Int)
  149.         base = (unsigned char *)XPNTR(string_lo);
  150.     else
  151.         wrong_type_argument(Qstringp,string_lo);
  152.  
  153.     base += index_ci;
  154.  
  155.     if (type_ls == Qchar)
  156.         return XSET(t,Lisp_Int,(long)*(char *)base);
  157.     else if (type_ls == Qunsigned_char)
  158.         return XSET(t,Lisp_Int,(long)(unsigned long)*(unsigned char *)base);
  159.     else if (type_ls == Qshort)
  160.         return XSET(t,Lisp_Int,(long)*(short *)base);
  161.     else if (type_ls == Qunsigned_short)
  162.         return XSET(t,Lisp_Int,(long)(unsigned long)*(unsigned short *)base);
  163.     else if (type_ls == Qlong)
  164.         return XSET(t,Lisp_Int,*(long *)base);
  165.     else if (type_ls == Qunsigned_long)
  166.         return XSET(t,Lisp_Int,*(long *)base);
  167.     else if (type_ls == Qverbatim_long)
  168.         return *(long *)base;
  169.     else if (type_ls == Qstring) {
  170.         CHECK_NUMBER(length_li,3);
  171.         return make_string((char *)base,length_li);
  172.     }
  173.     else if (type_ls == Qpascal_string) {
  174.         int length = (long)(unsigned long)*(unsigned char *)base;
  175.         return make_string((char *)base+1,length);
  176.     }
  177.     else
  178.         error("Illegal type '%s' passed to extract-internal",XSYMBOL(type_ls)->name->data);
  179. }
  180.  
  181. DEFUN("encode-internal",Fencode_internal,Sencode_internal,
  182.       4,4,0,
  183.       "Set STRING, starting at byte INDEX, using TYPE, to DATA, a lisp integer.\012"
  184.       "If TYPE is 'char, then the low byte of DATA is written.  If TYPE is\012"
  185.       "'short, then the low word of DATA is written.  If TYPE is 'long, then\012"
  186.       "the sign bit of DATA is extended to replace the type tag before a long\012"
  187.       "word is written.  If TYPE is 'unsigned-long, the data is zero-extended.\012"
  188.       "If TYPE is 'verbatim-long, then the data is written\012"
  189.       "verbatim.  If TYPE is 'string, then DATA must be a lisp string, and\012"
  190.       "the contents of the string, without a terminator or length record,\012"
  191.       "is written.  STRING can also be an integer, interpreted as an address.\012\012"
  192.       "Use of this function can easily crash Emacs or the entire machine.")
  193. (string_lo,index_li,type_ls,data_lo)
  194. {
  195.     int i,index_ci,base_li;
  196.     unsigned char *base;
  197.  
  198.     CHECK_NUMBER(index_li,1);
  199.     CHECK_SYMBOL(type_ls,2);
  200.     index_ci = XINT(index_li);
  201.  
  202.     if (XTYPE(string_lo) == Lisp_String) {
  203.         struct Lisp_String *string_ls = XSTRING(string_lo);
  204.         if (index_ci < 0 || index_ci >= string_ls->size) return Qnil;
  205.         base = string_ls->data;
  206.     }
  207.     else if (XTYPE(string_lo) == Lisp_Int)
  208.         base = (unsigned char *)XPNTR(string_lo);
  209.     else
  210.         wrong_type_argument(Qstringp,string_lo);
  211.  
  212.     base += index_ci;
  213.  
  214.     if (type_ls == Qlong)
  215.         *(long *)base = (long)XINT(data_lo);
  216.     else if (type_ls == Qunsigned_long)
  217.         *(unsigned long *)base = (unsigned long)XUINT(data_lo);
  218.     else if (type_ls == Qshort || type_ls == Qunsigned_short)
  219.         *(short *)base = (short)XINT(data_lo);
  220.     else if (type_ls == Qchar || type_ls == Qunsigned_char)
  221.         *(char *)base = (char)XINT(data_lo);
  222.     else if (type_ls == Qverbatim_long)
  223.         *(long *)base = data_lo;
  224.     else if (type_ls == Qstring)
  225.         for (i = 0; i<XSTRING(data_lo)->size; ++i)
  226.             base[i] = XSTRING(data_lo)->data[i];
  227.     else
  228.         error("Illegal type '%s' passed to encode-internal",XSYMBOL(type_ls)->name->data);
  229.  
  230.     return XSET(base_li,Lisp_Int,(int)base);
  231. }
  232.  
  233. DEFUN("FSSpec-to-unix-filename",FFSSpec_to_unix_filename,SFSSpec_to_unix_filename,
  234.      1,1,0,"Given an FSSpec record encoded in a Lisp string, return\012"
  235.      "the Unix-style filename for that FSSpec.")
  236. (spec_ls)
  237. {
  238.     Handle filename_cs;
  239.     FSSpec spec_c;
  240.     int err_ci;
  241.     Lisp_Object err_li,filename_ls;
  242.  
  243.     CHECK_STRING(spec_ls,0);
  244.     if (XSTRING(spec_ls)->size != sizeof(FSSpec)) return fnfErr;
  245.     memcpy((char *)&spec_c,(char *)XSTRING(spec_ls)->data,sizeof(FSSpec));
  246.     err_ci = FSSpec2unixfn(&spec_c,&filename_cs);
  247.     if (err_ci) return XSET(err_li,Lisp_Int,err_ci);
  248.     HLock(filename_cs);
  249.     filename_ls = make_string(*filename_cs,strlen(*filename_cs));
  250.     DisposHandle(filename_cs);
  251.     return filename_ls;
  252. }
  253.  
  254. DEFUN("unix-filename-to-FSSpec-internal",Funix_filename_to_FSSpec_internal,Sunix_filename_to_FSSpec_internal,
  255.       1,1,0,"Given a Unix-style filename, return a FSSpec record for it,\012"
  256.       "encoded in a Lisp string.")
  257. (filename)
  258. {
  259.     int err1;
  260.     FSSpec fs1;
  261.     Lisp_Object err,fs;
  262.  
  263.     CHECK_STRING(filename,0);
  264.     err1 = unixfn2FSSpec(XSTRING(filename)->data,&fs1,0);
  265.     fs = make_string((char *)&fs1,sizeof(FSSpec));
  266.     return Fcons(fs,XSET(err,Lisp_Int,err1));
  267. }
  268.  
  269. /* These declarations are here especially for Think C, for which Apple events
  270.    just weren't good enough. */
  271.  
  272. #if !defined(powerc)
  273. static long our_a5;
  274. #endif
  275.  
  276. enum {
  277.     uppGetNumLinesProcInfo = kPascalStackBased
  278.          | RESULT_SIZE(SIZE_CODE(sizeof(long)))
  279.          | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(void *))),
  280.     uppGetCharPosProcInfo = kPascalStackBased
  281.          | RESULT_SIZE(SIZE_CODE(sizeof(long)))
  282.          | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(void *)))
  283.          | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(long))),
  284.     uppGetLineNumProcInfo = kPascalStackBased
  285.          | RESULT_SIZE(SIZE_CODE(sizeof(short)))
  286.          | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(void *)))
  287.          | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(long)))
  288.          | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(long *)))
  289. };
  290.  
  291. static UniversalProcPtr tc_GetNumLines_funcptr;
  292. static UniversalProcPtr tc_GetCharPos_funcptr;
  293. static UniversalProcPtr tc_GetLineNum_funcptr;
  294.  
  295. static int
  296. tc_handler(struct buffer *b,int task,int data)
  297. {
  298.     /* task == 1, return number of lines in buffer
  299.        task == 2, given a line number, return the position of the first character of that line
  300.        task == 3, given a character position, return the number of line it's on
  301.        */
  302.     
  303.     register int i,j,nlines,s1,s2;
  304.     register unsigned char *p1,*p2;
  305.  
  306. #if !defined(powerc)
  307.     /* We're in a weird state here.  Emacs is not the current application,
  308.        TPM is.  We should be careful not to do many things, like call
  309.        WaitNextEvent. */
  310.     asm { move.l a5,-(a7) }
  311.     asm { move.l our_a5,a5 }
  312. #endif
  313.     
  314.     /* Get pointers and sizes of the two strings
  315.        that make up the visible portion of the buffer. */
  316.     
  317. #define BUF_FETCH_CHAR(buf,n) *(((n)>= BUF_GPT(buf) ? BUF_GAP_SIZE(buf) : 0) + \
  318.                                 (n) + BUF_BEG_ADDR(buf) - 1)
  319. #define BUF_BEGV_ADDR(buf) (&BUF_FETCH_CHAR(buf,(buf)->text.begv))
  320. #define BUF_GAP_END_ADDR(buf) ((buf)->text.beg + (buf)->text.gpt + (buf)->text.gap_size - 1)
  321.     
  322.     p1 = BUF_BEGV_ADDR(b);
  323.     s1 = BUF_GPT(b) - BUF_BEGV(b);
  324.     p2 = BUF_GAP_END_ADDR(b);
  325.     s2 = BUF_ZV(b) - BUF_GPT(b);
  326.     if (s1 < 0) {
  327.         p1 = p2;
  328.         s1 = BUF_ZV(b) - BUF_BEGV(b);
  329.         s2 = 0;
  330.     }
  331.     if (s2 < 0) {
  332.         s1 = BUF_ZV(b) - BUF_BEGV(b);
  333.         s2 = 0;
  334.     }
  335.     
  336.     i = j = 0;
  337.     nlines = 0;
  338.     while (i<s1) {
  339.         if (task == 1 && nlines == data) goto finished;
  340.         if (task == 2 && i == data) goto finished;
  341.         if (p1[i] == '\012') ++nlines;
  342.         ++i;
  343.     }
  344.     while (j<s2) {
  345.         if (task == 1 && nlines == data) goto finished;
  346.         if (task == 2 && i == data) goto finished;
  347.         if (p2[j] == '\012') ++nlines;
  348.         ++j;
  349.     }
  350.     if (s2 == 0 && s1 != 0) {
  351.         if (p1[s1-1] != '\012') ++nlines;
  352.     }
  353.     else if (s2 != 0) {
  354.         if (p2[s2-1] != '\012') ++nlines;
  355.     }
  356.     
  357.  finished:
  358. #if !defined(powerc)
  359.     asm { move.l (a7)+,a5 }
  360. #endif
  361.     return (task == 1 ? i+j : nlines);
  362. }
  363.  
  364. static pascal long
  365. tc_GetNumLines_func(struct buffer *b)
  366. {
  367.     return tc_handler(b,0,0);
  368. }
  369.  
  370. static pascal long
  371. tc_GetCharPos_func(struct buffer *b,long lineNum)
  372. {
  373.     return tc_handler(b,1,lineNum);
  374. }
  375.  
  376. static pascal short
  377. tc_GetLineNum_func(struct buffer *b,long charPos,long *line)
  378. {
  379.     *line = tc_handler(b,2,charPos);
  380.     return 0;
  381. }
  382.  
  383. DEFUN("special-menu-show-stdout",Fspecial_menu_show_stdout,Sspecial_menu_show_stdout,
  384.       2,2,0,0)
  385. (menu,item)
  386. {
  387.     tty_expose();
  388.     return Qnil;
  389. }
  390.  
  391. DEFUN("special-menu-font-change",Fspecial_menu_font_change,Sspecial_menu_font_change,
  392.       2,2,0,0)
  393. (font,size)
  394. {
  395.     CHECK_NUMBER(font,0);
  396.     CHECK_NUMBER(size,1);
  397.     console_change_fontsize(XINT(font),XINT(size));
  398.     return Qnil;
  399. }
  400.  
  401. DEFUN("get-preference",Fget_preference,Sget_preference,2,2,0,
  402.       "Return a handle to preference of type TYPE, index N in the Emacs preferences\012"
  403.       "file.  The handle returned is detached from the resource map of that file,\012"
  404.       "and should eventually be disposed by the caller.  A negative result indicates\012"
  405.       "an error, and is an OS error code.")
  406. (Lisp_Object type,Lisp_Object n)
  407. {
  408.     int err;
  409.     Handle h;
  410.     Lisp_Object result;
  411.  
  412.     CHECK_STRING(type,0);
  413.     CHECK_NUMBER(n,1);
  414.     err = get_preference(*(int *)XSTRING(type)->data,XINT(n),&h);
  415.     return XSET(result,Lisp_Int,err ? err : (int)h);
  416. }
  417.  
  418. DEFUN("set-preference",Fset_preference,Sset_preference,3,3,0,
  419.       "Set preference type TYPE, index N in the Emacs preferences file to\012"
  420.       "the data in HANDLE, replacing any such preference if it already exists.\012"
  421.       "The handle given becomes part of the resource map of the file, and\012"
  422.       "should not be disposed by the caller.  Return OS error code.")
  423. (Lisp_Object type_ls,Lisp_Object n_li,Lisp_Object h_li)
  424. {
  425.     Handle h_ci;
  426.     int n_ci,type_ci;
  427.     Lisp_Object result;
  428.     
  429.     CHECK_STRING(type_ls,0);
  430.     CHECK_NUMBER(n_li,1);
  431.     CHECK_NUMBER(h_li,2);
  432.  
  433.     h_ci = (Handle)XPNTR(h_li);
  434.     n_ci = XINT(n_li);
  435.     type_ci = *(int *)XSTRING(type_ls)->data;
  436.     return XSET(result,Lisp_Int,set_preference(type_ci,n_ci,h_ci));
  437. }
  438.  
  439. DEFUN("console-WindowPtr",Fconsole_WindowPtr,Sconsole_WindowPtr,0,0,0,
  440. "Returns a pointer to the Emacs window.")
  441. (void)
  442. {
  443.     Lisp_Object result;
  444.     return XSET(result,Lisp_Int,console_window());
  445. }
  446.  
  447. DEFUN("console-WCTabHandle",Fconsole_WCTabHandle,Sconsole_WCTabHandle,0,0,0,
  448. "Returns a handle to a copy of the WinCTab of the Emacs\012"
  449. "window.  Do not dispose of it.")
  450. (void)
  451. {
  452.     Lisp_Object result;
  453.     return XSET(result,Lisp_Int,console_WCTabHandle());
  454. }
  455.  
  456. DEFUN("execute-68k-trap",Fexecute_68k_trap,Sexecute_68k_trap,5,5,0,"Don't ask.")
  457. (stack,code_base,code_offset,inregs,out)
  458. {
  459.     int value,(*p)();
  460.     unsigned char *size;
  461.     Lisp_Object result,reglist;
  462.     struct regs_for_68k_traps regs;
  463.  
  464.     /* Set up registers going into call */
  465.     for (reglist = inregs; !NULL(reglist); reglist = Fcdr(reglist)) {
  466.         Lisp_Object regspec = Fcar(reglist);
  467.         unsigned char *regname = XSYMBOL(Fcar(regspec))->name->data;
  468.         int regval = XINT(Fcar(Fcdr(regspec)));
  469.         if      (!strcmp(regname,"d0")) regs.d0 = regval;
  470.         else if (!strcmp(regname,"d1")) regs.d1 = regval;
  471.         else if (!strcmp(regname,"d2")) regs.d2 = regval;
  472.         else if (!strcmp(regname,"a0")) regs.a0 = regval;
  473.         else if (!strcmp(regname,"a1")) regs.a1 = regval;
  474.     }
  475.  
  476.     p = (int (*)())((XTYPE(code_base) == Lisp_String ?
  477.                             (char *)XSTRING(code_base)->data :
  478.                             (char *)XPNTR(code_base))
  479.                         + code_offset);
  480.     
  481.     execute_68k_trap(p,(char *)XSTRING(stack)->data,XSTRING(stack)->size,®s);
  482.  
  483.     /* Extract output value */
  484.     if (XTYPE(out) == Lisp_Symbol && !NULL(out)) {
  485.         size = XSYMBOL(out)->name->data;
  486.         value = regs.d0;
  487.     }
  488.     else if (XTYPE(out) == Lisp_Cons) {
  489.         unsigned char *regname = XSYMBOL(Fcar(Fcdr(out)))->name->data;
  490.         size = XSYMBOL(Fcar(out))->name->data;
  491.         if      (!strcmp(regname,"d0")) value = regs.d0;
  492.         else if (!strcmp(regname,"d1")) value = regs.d1;
  493.         else if (!strcmp(regname,"d2")) value = regs.d2;
  494.         else if (!strcmp(regname,"a0")) value = regs.a0;
  495.         else if (!strcmp(regname,"a1")) value = regs.a1;
  496.         else return Qnil;
  497.     }
  498.     else
  499.         return Qnil;
  500.  
  501.     if (!strcmp(size,"long"))
  502.         return XSET(result,Lisp_Int,value);
  503.     else if (!strcmp(size,"short"))
  504.         return XSET(result,Lisp_Int,(long)(short)value);
  505.     else if (!strcmp(size,"char"))
  506.         return XSET(result,Lisp_Int,(long)(char)value);
  507.     else
  508.         return Qnil;
  509. }
  510.  
  511. static pascal void
  512. dialog_user_item_callback(DialogPtr d,short item)
  513. {
  514.     pass_up_lisp_command(Fcons(intern("dialog-user-item-callback"),
  515.                                Fcons((Lisp_Object)d,Fcons(item,Qnil))));
  516. }
  517.  
  518. static pascal Boolean
  519. modal_dialog_filter_callback(DialogPtr d,EventRecord *e,short *i)
  520. {
  521.     return pass_up_lisp_command(Fcons(intern("modal-dialog-filter-callback"),
  522.                                       Fcons((Lisp_Object)d,Fcons((Lisp_Object)e,Fcons((Lisp_Object)i,Qnil)))));
  523. }
  524.  
  525. void
  526. do_MenuSelect_before_hooks(void)
  527. {
  528.     Lisp_Object result,funcname;
  529.  
  530.     if (!NULL(funcname = Fintern_soft(build_string("do-MenuSelect-before-hooks"),Qnil)))
  531.         result = pass_up_lisp_command(Fcons(funcname,Qnil));
  532. }
  533.  
  534. void
  535. do_menu_internal(long choice)
  536. {
  537.     long now;
  538.     short menu,item;
  539.     Lisp_Object result,funcname;
  540.     
  541.     menu = HiWord(choice);
  542.     item = LoWord(choice);
  543.     now = TickCount();
  544.     
  545.     if (!NULL(funcname = Fintern_soft(build_string("do-menu"),Qnil)))
  546.         result = pass_up_lisp_command(Fcons(funcname,
  547.                                            Fcons(menu,
  548.                                                  Fcons(item,
  549.                                                        Qnil))));
  550.     else
  551.         result = Qnil;
  552.     
  553.     // Let the menu item remain highlighted for a short time
  554.     while (now + 10 >= TickCount())
  555.         ;
  556.     HiliteMenu(0);
  557. }
  558.  
  559. #if 0
  560.  
  561. static void
  562. enable_item(long mh,int item,int enable)
  563. {
  564.     if (enable)
  565.         EnableItem((MenuHandle)mh,item);
  566.     else
  567.         DisableItem((MenuHandle)mh,item);
  568. }
  569.  
  570. void
  571. fixup_menus()
  572. {
  573.     WindowPtr fw;
  574.     int cw,mw,lrnk,i,j,n,max,enable;
  575.     MenuHandle mh;
  576.     short c;
  577.     static int last_enable = -1;
  578.     
  579.     fw = FrontWindow();
  580.     cw = fw == console_window();
  581.     mw = fw == tty_window();
  582.     lrnk = 1;
  583.     enable = lrnk && cw;
  584.     if (enable == last_enable) return;
  585.     
  586.     // See IM pg I-346
  587.     max = *(short *)*MenuList / 6;
  588.     for (i = 1; i<max-2; ++i) {
  589.         mh = *(MenuHandle *)&(*MenuList)[6 + 6*i];
  590.         if (!pstrcmp((**mh).menuData,"\pFile")) {
  591.             n = CountMItems(mh);
  592.             for (j = 1; j<=n; ++j) {
  593.                 GetItemCmd(mh,j,&c);
  594.                 if (c == 'Q')
  595.                     enable_item((long)mh,j,1);
  596.                 else
  597.                     enable_item((long)mh,j,enable);
  598.             }
  599.         }
  600.         else
  601.             enable_item((long)mh,0,enable);
  602.     }
  603.     
  604.     DrawMenuBar();
  605.     last_enable = enable;
  606. }
  607.  
  608. #endif
  609.  
  610. static UserItemUPP dialog_user_item_callback_UPP;
  611. static ModalFilterUPP modal_dialog_filter_callback_UPP;
  612. static AEIdleUPP ae_send_idle_function_UPP;
  613. static AEEventHandlerUPP ae_receive_func_UPP;
  614. static UniversalProcPtr CreateObjSpecifier_UPP;
  615.  
  616. enum {
  617.     uppCreateObjSpecifierProcInfo = kPascalStackBased
  618.          | RESULT_SIZE(SIZE_CODE(sizeof(OSErr)))
  619.          | STACK_ROUTINE_PARAMETER(1, SIZE_CODE(sizeof(DescType)))
  620.          | STACK_ROUTINE_PARAMETER(2, SIZE_CODE(sizeof(AEDesc *)))
  621.          | STACK_ROUTINE_PARAMETER(3, SIZE_CODE(sizeof(DescType)))
  622.          | STACK_ROUTINE_PARAMETER(4, SIZE_CODE(sizeof(AEDesc *)))
  623.          | STACK_ROUTINE_PARAMETER(5, SIZE_CODE(sizeof(Boolean)))
  624.          | STACK_ROUTINE_PARAMETER(6, SIZE_CODE(sizeof(AEDesc *)))
  625. };
  626.  
  627. void
  628. init_apple(void)
  629. {
  630.     long **h;
  631.     extern pascal short ae_receive_func();
  632.     extern pascal short ae_send_idle_function();
  633.  
  634. #if !defined(powerc)
  635.     asm { move.l a5,our_a5 }
  636. #endif
  637.     tc_GetNumLines_funcptr = NewRoutineDescriptor(tc_GetNumLines_func,uppGetNumLinesProcInfo,GetCurrentISA());
  638.     tc_GetCharPos_funcptr = NewRoutineDescriptor(tc_GetCharPos_func,uppGetCharPosProcInfo,GetCurrentISA());
  639.     tc_GetLineNum_funcptr = NewRoutineDescriptor((long (*)())tc_GetLineNum_func,uppGetLineNumProcInfo,GetCurrentISA());
  640.     ae_receive_func_UPP = NewAEEventHandlerProc(ae_receive_func);
  641.     ae_send_idle_function_UPP = NewAEIdleProc(ae_send_idle_function);
  642.     dialog_user_item_callback_UPP = NewUserItemProc(dialog_user_item_callback);
  643.     modal_dialog_filter_callback_UPP = NewModalFilterProc(modal_dialog_filter_callback);
  644.     CreateObjSpecifier_UPP = NewRoutineDescriptor((long (*)())CreateObjSpecifier,
  645.                                                   uppCreateObjSpecifierProcInfo,
  646.                                                   GetCurrentISA());
  647.  
  648.     if (initialized) {
  649.         char *new_trap_code = NewPtr(XINT(Vmac_trap_code_max));
  650.         if (MemError()) ExitToShell();
  651.         memcpy((char *)new_trap_code,(char *)XSTRING(Vmac_trap_code)->data,XSTRING(Vmac_trap_code)->size);
  652.         XSET(Vmac_trap_code,Lisp_Int,(int)new_trap_code);
  653.     }
  654.     else {
  655.         Vmac_trap_code_max = 5000;
  656.         Vmac_trap_code = make_string((char *)0,Vmac_trap_code_max);
  657.     }
  658. }
  659.  
  660. void
  661. syms_of_apple(void)
  662. {
  663.     // Reloading the dump will restore this variables to the wrong values.
  664.     // But init_apple above will fix them.
  665.  
  666.     DEFVAR_INT("tc:GetNumLines",(int *)&tc_GetNumLines_funcptr,0L);
  667.     DEFVAR_INT("tc:GetCharPos",(int *)&tc_GetCharPos_funcptr,0L);
  668.     DEFVAR_INT("tc:GetLineNum",(int *)&tc_GetLineNum_funcptr,0L);
  669.  
  670.     DEFVAR_INT("AESend-idle-function",(int *)&ae_send_idle_function_UPP,0L);
  671.     DEFVAR_INT("ae-receive",(int *)&ae_receive_func_UPP,0L);
  672.     DEFVAR_INT("dialog-user-item-callback",(int *)&dialog_user_item_callback_UPP,0L);
  673.     DEFVAR_INT("modal-dialog-filter-callback",(int *)&modal_dialog_filter_callback_UPP,0L);
  674.     DEFVAR_INT("CreateObjSpecifier",(int *)&CreateObjSpecifier_UPP,0L);
  675.     
  676.     DEFVAR_BOOL("powerc",&Vpowerc,"True if we're running on PPC architecture");
  677. #if defined(powerc)
  678.     Vpowerc = 1;
  679. #else
  680.     Vpowerc = 0;
  681. #endif
  682.     DEFVAR_BOOL("accept-high-level-events",&Vaccept_high_level_events,0L);
  683.     Vaccept_high_level_events = 0;
  684.     DEFVAR_BOOL("quit-in-main-event-loop",&Vquit_in_main_event_loop,0L);
  685.     Vquit_in_main_event_loop = 0;
  686.     DEFVAR_INT("min-stack-size",&Vmin_stack_size,0L);
  687.     Vmin_stack_size = MIN_STACK_SIZE;
  688.     DEFVAR_LISP("modifier-vector",&Vmodifier_vector,0L);
  689.  
  690.     DEFVAR_LISP("mac-trap-code",&Vmac_trap_code,0L);
  691.     DEFVAR_INT("mac-trap-code-max",&Vmac_trap_code_max,0L);
  692.     DEFVAR_INT("mac-trap-code-end",&Vmac_trap_code_end,0L);
  693.     Vmac_trap_code_end = 0;
  694.  
  695.     Qchar = intern("char"); staticpro(&Qchar);
  696.     Qshort = intern("short"); staticpro(&Qshort);
  697.     Qlong = intern("long"); staticpro(&Qlong);
  698.     Qunsigned_char = intern("unsigned-char"); staticpro(&Qunsigned_char);
  699.     Qunsigned_short = intern("unsigned-short"); staticpro(&Qunsigned_short);
  700.     Qunsigned_long = intern("unsigned-long"); staticpro(&Qunsigned_long);
  701.     Qverbatim_long = intern("verbatim-long"); staticpro(&Qverbatim_long);
  702.     Qstring = intern("string"); staticpro(&Qstring);
  703.     Qpascal_string = intern("pascal-string"); staticpro(&Qpascal_string);
  704.  
  705.     defsubr(&Sstring_data);
  706.     defsubr(&Sextract_internal);
  707.     defsubr(&Sencode_internal);
  708.  
  709.     defsubr(&Sunix_filename_to_FSSpec_internal);
  710.     defsubr(&SFSSpec_to_unix_filename);
  711.  
  712.     defsubr(&Sspecial_menu_show_stdout);
  713.     defsubr(&Sspecial_menu_font_change);
  714.  
  715.     defsubr(&Sget_preference);
  716.     defsubr(&Sset_preference);
  717.     defsubr(&Sconsole_WindowPtr);
  718.     defsubr(&Sconsole_WCTabHandle);
  719.     defsubr(&Sexecute_68k_trap);
  720. }
  721.