mirror of
https://github.com/Interlisp/maiko.git
synced 2026-01-26 20:02:37 +00:00
Maiko sources matching state as of 020102 prior to initial patching for Mac OSX
This commit is contained in:
Nick Briggs
786
src/subr.c
Executable file
786
src/subr.c
Executable file
@@ -0,0 +1,786 @@
|
||||
/* $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 <stdio.h>
|
||||
#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 */
|
||||
Reference in New Issue
Block a user