/* $Id: subr.c,v 1.3 1999/05/31 23:35:42 sybalsky Exp $ (C) Copyright Venue, All Rights Reserved */ static char *id = "$Id: subr.c,v 1.3 1999/05/31 23:35:42 sybalsky Exp $ Copyright (C) Venue"; /************************************************************************/ /* */ /* (C) Copyright 1989-95 Venue. All Rights Reserved. */ /* Manufactured in the United States of America. */ /* */ /* The contents of this file are proprietary information */ /* belonging to Venue, and are provided to you under license. */ /* They may not be further distributed or disclosed to third */ /* parties without the specific permission of Venue. */ /* */ /************************************************************************/ #include "version.h" /***********************************************************/ /* File Name : subr.c Including : OP_subrcall Created : May 12, 1987 Takeshi Shimizu Changed : May 15 87 take Changed : Jun 2 87 NMitani Jun. 5 87 take Jun. 29 87 NMitani Oct. 13 87 Hayata Oct. 16 87 take Nov. 18 87 Matsuda Dec. 17 1987 Tomtom 2/17/89 Sybalsky (Add SXHASH) */ /***********************************************************/ #include #include "lispemul.h" #include "address.h" #include "adr68k.h" #include "lsptypes.h" #include "lispmap.h" #include "lspglob.h" #include "cell.h" #include "stack.h" #include "arith.h" #include "subrs.h" #include "profile.h" #include "dbprint.h" extern LispPTR *PENDINGINTERRUPT68k; /***********************************************************/ /* Func Name : OP_subrcall Last Modify : 13-Oct 1987 take */ /***********************************************************/ #ifdef NATIVETRAN extern int *c_ret_to_dispatch; extern int *ret_to_dispatch; #endif extern LispPTR Uraid_mess; LispPTR subr_lisperror(); /* 0377 */ char *atom_to_str(LispPTR atom_index) { PNCell *pnptr; char *pname_base; pnptr = (PNCell *) GetPnameCell(atom_index); pname_base = (char *) Addr68k_from_LADDR(pnptr->pnamebase); return(pname_base+1); } /*atom_to_str*/ #define POP_SUBR_ARGS \ { args[0] = NIL_PTR; \ if (( arg_num = (argnum/* = (Get_BYTE(PC+2))*/)) > 0) { \ while(arg_num >0) \ PopStackTo(args[--arg_num]); \ } \ } OP_subrcall(int subr_no, int argnum) { static LispPTR args[30]; int arg_num; int i; PushCStack; /* save TOS in memory */ DBPRINT(("Subr call to subr 0%o.\n", subr_no)); switch(subr_no) { case sb_SHOWDISPLAY :POP_SUBR_ARGS; DSP_showdisplay(args); break;/* showdisplay */ case sb_DSPBOUT : POP_SUBR_ARGS; DSP_dspbout( args ); break; /*dspbout */ case sb_RAID : POP_SUBR_ARGS; Uraid_mess= args[0]; PC+= 3; /* for the case of hardreset */ error("URAID Called:"); Uraid_mess=NIL; TopOfStack =NIL; return; /* Direct return;avoid to increment PC */ /* break; */ /*************************/ /* for Local File System */ /*************************/ case sb_COM_OPENFILE : POP_SUBR_ARGS; TopOfStack = COM_openfile(args); break; case sb_COM_CLOSEFILE : POP_SUBR_ARGS; TopOfStack = COM_closefile(args); break; case sb_UFS_GETFILENAME : POP_SUBR_ARGS; TopOfStack = UFS_getfilename(args); break; case sb_UFS_DELETEFILE : POP_SUBR_ARGS; TopOfStack = UFS_deletefile(args); break; case sb_UFS_RENAMEFILE : POP_SUBR_ARGS; TopOfStack = UFS_renamefile(args); break; case sb_COM_READPAGES : POP_SUBR_ARGS; TopOfStack = COM_readpage(args); break; case sb_COM_WRITEPAGES : POP_SUBR_ARGS; TopOfStack = COM_writepage(args); break; case sb_COM_TRUNCATEFILE : POP_SUBR_ARGS; TopOfStack = COM_truncatefile(args); break; case sb_COM_NEXT_FILE : POP_SUBR_ARGS; TopOfStack = COM_next_file(args); break; case sb_COM_FINISH_FINFO : POP_SUBR_ARGS; TopOfStack = COM_finish_finfo(args); break; case sb_COM_GEN_FILES : POP_SUBR_ARGS; TopOfStack = COM_gen_files(args); break; case sb_UFS_DIRECTORYNAMEP : POP_SUBR_ARGS; TopOfStack = UFS_directorynamep(args); break; case sb_COM_GETFILEINFO : POP_SUBR_ARGS; TopOfStack = COM_getfileinfo(args); break; case sb_COM_CHANGEDIR : POP_SUBR_ARGS; TopOfStack = COM_changedir(args); break; case sb_COM_GETFREEBLOCK: POP_SUBR_ARGS; TopOfStack = COM_getfreeblock(args); break; case sb_COM_SETFILEINFO: POP_SUBR_ARGS; TopOfStack = COM_setfileinfo(args); break; /*************/ /* for Timer */ /*************/ case sb_SETUNIXTIME : POP_SUBR_ARGS; TopOfStack = subr_settime(args); break; case sb_GETUNIXTIME : POP_SUBR_ARGS; TopOfStack = subr_gettime(args); break; case sb_COPYTIMESTATS : POP_SUBR_ARGS; TopOfStack = subr_copytimestats(args); break; /*************/ /* for Ether */ /*************/ case sb_CHECK_SUM :POP_SUBR_ARGS; TopOfStack = check_sum(args); break; case sb_ETHER_SUSPEND : POP_SUBR_ARGS; TopOfStack = ether_suspend(args); break; case sb_ETHER_RESUME : POP_SUBR_ARGS; TopOfStack = ether_resume(args); break; case sb_ETHER_AVAILABLE : POP_SUBR_ARGS; TopOfStack = ether_ctrlr(args); break; case sb_ETHER_RESET : POP_SUBR_ARGS; TopOfStack = ether_reset(args); break; case sb_ETHER_GET : POP_SUBR_ARGS; TopOfStack = ether_get(args); break; case sb_ETHER_SEND : POP_SUBR_ARGS; TopOfStack = ether_send(args); break; case sb_ETHER_SETFILTER : POP_SUBR_ARGS; TopOfStack = ether_setfilter(args); break; case sb_ETHER_CHECK: POP_SUBR_ARGS; TopOfStack = check_ether(); break; /***************/ /* for Display */ /***************/ case sb_DSPCURSOR : POP_SUBR_ARGS; DSP_Cursor(args, argnum); break; case sb_SETMOUSEXY : POP_SUBR_ARGS; DSP_SetMousePos(args); break; case sb_DSP_VIDEOCOLOR : POP_SUBR_ARGS; TopOfStack = DSP_VideoColor(args); break; case sb_DSP_SCREENWIDTH : POP_SUBR_ARGS; TopOfStack = DSP_ScreenWidth(args); break; case sb_DSP_SCREENHEIGHT : POP_SUBR_ARGS; TopOfStack = DSP_ScreenHight(args); break; /*************************/ /* for color experiments */ /*************************/ #ifdef COLOR case sb_COLOR_INIT : POP_SUBR_ARGS; TopOfStack=cgfour_init_color_display(args[0]); break; case sb_COLOR_SCREENMODE : POP_SUBR_ARGS; TopOfStack=cgfour_change_screen_mode(args[0]); break; case sb_COLOR_MAP : POP_SUBR_ARGS; TopOfStack=cgfour_set_colormap(args); break; case sb_COLOR_BASE : POP_SUBR_ARGS; /* retun DLword offsetbetween LISPBASE and Lisp_world */ TopOfStack=S_POSITIVE |(((int)Lisp_world >> 1) & 0xffff); break; case sb_C_SlowBltChar : POP_SUBR_ARGS; /* \\SLOWBLTCHAR for 8BITCOLOR */ C_slowbltchar(args); break; case 0215 : POP_SUBR_ARGS; Uncolorize_Bitmap(args); break; case 0216 : POP_SUBR_ARGS; Colorize_Bitmap(args); break; case 0217 : POP_SUBR_ARGS; Draw_8BppColorLine(args); break; #endif /* COLOR */ /***************************/ /*** bitbltsub, bltchar ***/ /***************************/ case sb_BITBLTSUB : POP_SUBR_ARGS; bitbltsub(args); break; case sb_BLTCHAR : POP_SUBR_ARGS; /* argnum * DLwordsperCell*/ bltchar(args); break; case sb_NEW_BLTCHAR : POP_SUBR_ARGS; newbltchar(args); break; case sb_TEDIT_BLTCHAR : POP_SUBR_ARGS; tedit_bltchar(args); break; /* case 209: JDS 4 may 91 - this is code for CHAR-FILLBUFFER?? */ case sb_BITBLT_BITMAP: POP_SUBR_ARGS; /* BITBLT to a bitmap */ { TopOfStack = bitblt_bitmap(args); break; } break; case 0111/*sb_BITSHADE_BITMAP*/: POP_SUBR_ARGS; /* BITSHADE to a bitmap */ { TopOfStack = bitshade_bitmap(args); break; } break; /**************/ /* For RS232C */ /**************/ #ifdef RS232 case sb_RS232C_CMD: RS232C_cmd(); break; case sb_RS232C_READ_INIT: RS232C_readinit(); break; case sb_RS232C_WRITE: RS232C_write(); break; #endif /* RS232 */ /***********/ /* for K/B */ /***********/ case sb_KEYBOARDBEEP : POP_SUBR_ARGS; KB_beep(args); break; case sb_KEYBOARDMAP : POP_SUBR_ARGS; KB_setmp(args); break; case sb_KEYBOARDSTATE : POP_SUBR_ARGS; KB_enable(args); break; case sb_VMEMSAVE: POP_SUBR_ARGS; TopOfStack = vmem_save0(args); break; case sb_LISPFINISH: case sb_LISP_FINISH : POP_SUBR_ARGS; if((argnum>0)&&(args[0]==S_POSITIVE)) /* 8/03/88 This branch impossible to take, subr has no args */ {TopOfStack=suspend_lisp(args);} else lisp_finish(); break; case sb_NEWPAGE : POP_SUBR_ARGS; TopOfStack = newpage(args[0]); break; case sb_DORECLAIM : POP_SUBR_ARGS; doreclaim(); /* top-level GC function */ TopOfStack = NIL_PTR; break; /* read & write a abs memory address */ case sb_NATIVE_MEMORY_REFERENCE : POP_SUBR_ARGS; switch (args[0] & 0xffff) { case 00: {register UNSIGNED iarg; if (argnum != 2) goto ret_nil; N_GETNUMBER(args[1], iarg, ret_nil); ARITH_SWITCH(*((LispPTR *) iarg), TopOfStack); break; } case 01: {register UNSIGNED iarg,iarg2; if (argnum != 3) goto ret_nil; N_GETNUMBER(args[1], iarg, ret_nil); N_GETNUMBER(args[2], iarg2, ret_nil); *((LispPTR *) iarg) = iarg2; break; } #ifdef NATIVETRAN case 02: /* get an emulator address */ {register UNSIGNED iarg; if (argnum != 2) goto ret_nil; switch (args[1] & 0xffff) { case 00: iarg = (UNSIGNED) &c_ret_to_dispatch; break; case 01: iarg = (UNSIGNED) &ret_to_dispatch; break; } ARITH_SWITCH(iarg, TopOfStack); break; } #endif } break; ret_nil: TopOfStack = NIL_PTR; break; #ifdef NATIVETRAN /* old load native (should be superceeded) */ case sb_OLD_COMPILE_LOAD_NATIVE : POP_SUBR_ARGS; { TopOfStack = do_system_call(args[0]); break; }; #endif case sb_DISABLEGC : POP_SUBR_ARGS; disablegc1(NIL); TopOfStack = NIL_PTR; break; case sb_GET_NATIVE_ADDR_FROM_LISP_PTR: POP_SUBR_ARGS; {ARITH_SWITCH(Addr68k_from_LADDR(args[0]), TopOfStack); break; } case sb_GET_LISP_PTR_FROM_NATIVE_ADDR: POP_SUBR_ARGS; {register UNSIGNED iarg; N_GETNUMBER(args[0], iarg, ret_nil); ARITH_SWITCH(LADDR_from_68k(iarg), TopOfStack); break; }; #ifdef NATIVETRAN case sb_LOAD_NATIVE_FILE: POP_SUBR_ARGS; /* to become OBSOLETE */ {TopOfStack = dynamic_load_code(args); break; } #endif case sb_DSK_GETFILENAME : POP_SUBR_ARGS; TopOfStack = DSK_getfilename(args); break; case sb_DSK_DELETEFILE : POP_SUBR_ARGS; TopOfStack = DSK_deletefile(args); break; case sb_DSK_RENAMEFILE : POP_SUBR_ARGS; TopOfStack = DSK_renamefile(args); break; case sb_DSK_DIRECTORYNAMEP : POP_SUBR_ARGS; TopOfStack = DSK_directorynamep(args); break; /* Communications with Unix Subprocess */ case sb_UNIX_HANDLECOMM: POP_SUBR_ARGS; #ifndef DOS TopOfStack = Unix_handlecomm(args); #endif /* DOS */ break; #ifdef OCR case sb_OCR_COMM: POP_SUBR_ARGS; TopOfStack = ocr_comm(args); break; #endif /* OCR */ /* case 0166: POP_SUBR_ARGS; error("called SUBR 0166, not defined!!"); {register int temp; N_GETNUMBER(TopOfStack, temp, badarg); temp = (UNSIGNED) Addr68k_from_LADDR(temp); ARITH_SWITCH(temp, TopOfStack); break; badarg: TopOfStack = NIL; break; } */ /* OS message print routines */ case sb_MESSAGE_READP: POP_SUBR_ARGS; TopOfStack = mess_readp(); break; case sb_MESSAGE_READ: POP_SUBR_ARGS; TopOfStack = mess_read(args); break; /* RPC routines */ case sb_RPC_CALL: POP_SUBR_ARGS; TopOfStack = rpc(args); break; /* Unix username/password utilities */ case sb_CHECKBCPLPASSWORD: POP_SUBR_ARGS; /* Check Unix username/password */ TopOfStack = check_unix_password(args); break; case sb_UNIX_USERNAME: POP_SUBR_ARGS; /* Get Unix username */ TopOfStack = unix_username(args); break; case sb_UNIX_FULLNAME: POP_SUBR_ARGS; /* Get Unix person-name (GECOS field) */ TopOfStack = unix_fullname(args); break; case sb_UNIX_GETENV: POP_SUBR_ARGS; /* get value of environment variable, or NIL */ TopOfStack = unix_getenv(args); break; case sb_UNIX_GETPARM: POP_SUBR_ARGS; /* get built in parameter */ TopOfStack = unix_getparm(args); break; case sb_SUSPEND_LISP: POP_SUBR_ARGS; /* Suspend Maiko */ TopOfStack = suspend_lisp(args); break; case sb_MONITOR_CONTROL : POP_SUBR_ARGS; /* MONITOR CONTROL STOP(0) or RESUME(1) */ #ifdef PROFILE moncontrol(args[0] & 1); #endif /* PROFILE */ break; /*****************/ /* Character I/O */ /*****************/ case sb_CHAR_OPENFILE: POP_SUBR_ARGS; /* Char-device openfile. */ TopOfStack = CHAR_openfile(args); break; case sb_CHAR_BIN: POP_SUBR_ARGS; /* Char-device bin. */ { TopOfStack = CHAR_bin(args[0], args[1]); break; } break; case sb_CHAR_BOUT: POP_SUBR_ARGS; /* Char-device bout. */ { TopOfStack = CHAR_bout(args[0], args[1], args[2]); break; } break; case sb_CHAR_IOCTL: POP_SUBR_ARGS; /* Char-device IOCTL. */ { TopOfStack = CHAR_ioctl(args); break; } break; case sb_CHAR_CLOSEFILE: POP_SUBR_ARGS; /* Char-device CLOSEFILE. */ { TopOfStack = CHAR_closefile(args); break; } break; case sb_CHAR_BINS: POP_SUBR_ARGS; /* Char-device \BINS. */ { TopOfStack = CHAR_bins(args); break; } break; case sb_CHAR_BOUTS: POP_SUBR_ARGS; /* Char-device \BOUTS. */ { TopOfStack = CHAR_bouts(args); break; } break; case sb_TCP_OP: POP_SUBR_ARGS; /* TCP operations */ { TopOfStack = subr_TCP_ops(args[0], args[1], args[2], args[3], args[4], args[5]); break; } break; #ifdef TRUECOLOR case sb_PICTURE_OP: { POP_SUBR_ARGS; TopOfStack = Picture_Op( args ); } break; case sb_TRUE_COLOR_OP: { POP_SUBR_ARGS; TopOfStack = TrueColor_Op( args ); } break; #ifdef VIDEO case sb_VIDEO_OP: { POP_SUBR_ARGS; TopOfStack = Video_Op( args ); } break; #endif /* VIDEO */ #endif /* TRUECOLOR */ case sb_PUPLEVEL1STATE: POP_SUBR_ARGS; /* Do nothing with PUP on sun */ break; case sb_WITH_SYMBOL: POP_SUBR_ARGS; /* Symbol lookup */ { TopOfStack = with_symbol(args[0], args[1], args[2], args[3], args[4], args[5]); break; } case 0222: /* Cause an interrupt to occur. Used by */ /* Lisp INTERRUPTED to re-set an interrupt */ /* when it's uninterruptable. */ { POP_SUBR_ARGS; Irq_Stk_Check = Irq_Stk_End=0; *PENDINGINTERRUPT68k = ATOM_T; TopOfStack = ATOM_T; break; } /*******************/ /* CLX Support ops */ /*******************/ #ifdef NEVER /* CLX */ case sb_OPEN_SOCKET: { POP_SUBR_ARGS; TopOfStack = Open_Socket( args ); break; } case sb_CLOSE_SOCKET: { TopOfStack = Close_Socket(); break; } case sb_READ_SOCKET: { POP_SUBR_ARGS; TopOfStack = Read_Socket( args ); break; } case sb_WRITE_SOCKET: { POP_SUBR_ARGS; TopOfStack = Write_Socket( args ); break; } case 0244: /* KB_TRANSITION */ { POP_SUBR_ARGS; TopOfStack = Kbd_Transition( args ); break; } #endif /* CLX */ #ifndef NOFORN /*****************************************/ /* foreign-function-call support subrs */ /*****************************************/ case sb_CALL_C_FN: { POP_SUBR_ARGS; TopOfStack = call_c_fn( args ); /* args[0]=fnaddr, args[1]=fn type */ break; } case sb_DLD_LINK: { POP_SUBR_ARGS; TopOfStack = Mdld_link( args ); break; } case sb_DLD_UNLINK_BY_FILE: { POP_SUBR_ARGS; TopOfStack = Mdld_unlink_by_file( args ); break; } case sb_DLD_UNLINK_BY_SYMBOL: { POP_SUBR_ARGS; TopOfStack = Mdld_unlink_by_symbol( args ); break; } case sb_DLD_GET_SYMBOL: { POP_SUBR_ARGS; TopOfStack = Mdld_get_symbol( args ); break; } case sb_DLD_GET_FUNC: { POP_SUBR_ARGS; TopOfStack = Mdld_get_func( args ); break; } case sb_DLD_FUNCTION_EXECUTABLE_P: { POP_SUBR_ARGS; TopOfStack = Mdld_function_executable_p( args ); break; } case sb_DLD_LIST_UNDEFINED_SYM: { POP_SUBR_ARGS; TopOfStack = Mdld_list_undefined_sym( ); break; } case sb_MALLOC: { POP_SUBR_ARGS; TopOfStack = c_malloc( args ); break; } case sb_FREE: { POP_SUBR_ARGS; TopOfStack = c_free( args ); break; } case sb_PUT_C_BASEBYTE: { POP_SUBR_ARGS; TopOfStack = put_c_basebyte( args ); break; } case sb_GET_C_BASEBYTE: { POP_SUBR_ARGS; TopOfStack = get_c_basebyte( args ); break; } case sb_SMASHING_APPLY: { POP_SUBR_ARGS; TopOfStack = smashing_c_fn( args ); break; } #endif /* NOFORN */ #ifdef MNW case sb_FILL_IN: { POP_SUBR_ARGS; TopOfStack = init_mnw_instance( args ); break; } case sb_QUERY_WINDOWS: { break; } case sb_MNW_OP: { POP_SUBR_ARGS; TopOfStack = dispatch_mnw_method( args ); break; } #endif /* MNW */ #ifdef LPSOLVE /* Linear-programming solver interface from Lisp */ case sb_LP_SETUP: { POP_SUBR_ARGS; TopOfStack = lpsetup(args[0], args[1], args[2], args[3], args[4], args[5], args[6], args[7], args[8], args[9], args[10]); break; } case sb_LP_RUN: { POP_SUBR_ARGS; TopOfStack = lpmain(args[0]); break; } #endif /* LPSOLVE */ default : { char errtext[200]; sprintf ( errtext, "OP_subrcall: Invalid alpha byte 0%o", ((*(PC+1)) & 0xff)); printf ( "%s\n", errtext ); error(errtext); break; } }/* switch end */ PC += 3; /* Move PC forward to next opcode */ }/* OP_subrcall */