github.com/Interlisp.maiko
1
0
Fork 0
mirror of https://github.com/Interlisp/maiko.git synced 2026-03-05 18:49:09 +00:00
Code Issues Projects Releases Wiki Activity
Files
original-020102-01
Interlisp.maiko/src/subr.c

787 lines
18 KiB
C
Executable File
Raw Permalink Blame History

/* $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 View Git Blame Copy Permalink