github.com/Interlisp.maiko
1
0
Fork 0
mirror of https://github.com/Interlisp/maiko.git synced 2026-01-15 15:57:13 +00:00
Code Issues Projects Releases Wiki Activity
Interlisp.maiko/src/subr.c
Nick Briggs f7e40d1ed5 Use symbolic constants for COLOR related subrs rather than numbers 
cases for subrs UNCOLORIZE-BITMAP, COLORIZE-BITMAP, COLOR-8BPPDRAWLINE (which
are not compiled into current code) can have the numbers replaced by the
symbolic constants that are now defined in subrs.h
2021-09-19 14:19:42 -07:00

813 lines
19 KiB
C
Raw Permalink Blame History

/* $Id: subr.c,v 1.3 1999/05/31 23:35:42 sybalsky Exp $ (C) Copyright Venue, All Rights Reserved */
/************************************************************************/
/* */
/* (C) Copyright 1989-95 Venue. All Rights Reserved. */
/* Manufactured in the United States of America. */
/* */
/************************************************************************/
#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 <time.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 "dbprint.h"
#include "subrdefs.h"
#include "bbtsubdefs.h"
#include "chardevdefs.h"
#include "commondefs.h"
#include "dirdefs.h"
#include "dskdefs.h"
#include "dspsubrsdefs.h"
#include "etherdefs.h"
#include "gcarraydefs.h"
#include "gcrdefs.h"
#include "inetdefs.h"
#include "kbdsubrsdefs.h"
#include "mkcelldefs.h"
#include "osmsgdefs.h"
#include "rpcdefs.h"
#include "storagedefs.h"
#include "timerdefs.h"
#include "ufsdefs.h"
#include "unixcommdefs.h"
#include "uutilsdefs.h"
#include "vmemsavedefs.h"
#ifdef MAIKO_ENABLE_FOREIGN_FUNCTION_INTERFACE
#include "foreigndefs.h"
#endif
extern LispPTR *PENDINGINTERRUPT68k;
/***********************************************************/
/*
Func Name : OP_subrcall
Last Modify : 13-Oct 1987 take
*/
/***********************************************************/
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 \
do { \
args[0] = NIL_PTR; \
if ((arg_num = (argnum /* = (Get_BYTE(PC+2))*/)) > 0) { \
while (arg_num > 0) PopStackTo(args[--arg_num]); \
} \
} while(0)
void OP_subrcall(int subr_no, int argnum) {
static LispPTR args[30];
int arg_num;
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;
subr_settime(args);
/* don't know whether it worked or not */
TopOfStack = NIL;
break;
case sb_GETUNIXTIME:
POP_SUBR_ARGS;
TopOfStack = subr_gettime(args);
break;
case sb_COPYTIMESTATS:
POP_SUBR_ARGS;
subr_copytimestats(args);
/* no result */
TopOfStack = NIL;
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;
/* return DLword offset between 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 sb_UNCOLORIZE_BITMAP:
POP_SUBR_ARGS;
Uncolorize_Bitmap(args);
break;
case sb_COLORIZE_BITMAP:
POP_SUBR_ARGS;
Colorize_Bitmap(args);
break;
case sb_COLOR_8BPPDRAWLINE:
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;
case 0111 /*sb_BITSHADE_BITMAP*/:
POP_SUBR_ARGS; /* BITSHADE to a bitmap */
TopOfStack = bitshade_bitmap(args);
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;
}
/* case 02: Used to be get an emulator address for
* defunct NATIVETRAN feature. */
}
break;
ret_nil:
TopOfStack = NIL_PTR;
break;
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;
};
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;
/*
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;
case sb_CHAR_BOUT:
POP_SUBR_ARGS; /* Char-device bout. */
TopOfStack = CHAR_bout(args[0], args[1], args[2]);
break;
case sb_CHAR_IOCTL:
POP_SUBR_ARGS; /* Char-device IOCTL. */
TopOfStack = CHAR_ioctl(args);
break;
case sb_CHAR_CLOSEFILE:
POP_SUBR_ARGS; /* Char-device CLOSEFILE. */
TopOfStack = CHAR_closefile(args);
break;
case sb_CHAR_BINS:
POP_SUBR_ARGS; /* Char-device \BINS. */
TopOfStack = CHAR_bins(args);
break;
case sb_CHAR_BOUTS:
POP_SUBR_ARGS; /* Char-device \BOUTS. */
TopOfStack = CHAR_bouts(args);
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;
#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 sb_CAUSE_INTERRUPT: /* Cause an interrupt to occur. Used by */
/* Lisp INTERRUPTED to re-set an interrupt */
/* when it's uninterruptible. */
POP_SUBR_ARGS;
Irq_Stk_Check = Irq_Stk_End = 0;
*PENDINGINTERRUPT68k = ATOM_T;
TopOfStack = ATOM_T;
break;
#ifdef MAIKO_ENABLE_FOREIGN_FUNCTION_INTERFACE
/*****************************************/
/* foreign-function-call support subrs */
/*****************************************/
case sb_CALL_C_FUNCTION: {
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_SYMBOLS: {
POP_SUBR_ARGS;
TopOfStack = Mdld_list_undefined_sym();
break;
}
case sb_C_MALLOC: {
POP_SUBR_ARGS;
TopOfStack = c_malloc(args);
break;
}
case sb_C_FREE: {
POP_SUBR_ARGS;
TopOfStack = c_free(args);
break;
}
case sb_C_PUTBASEBYTE: {
POP_SUBR_ARGS;
TopOfStack = put_c_basebyte(args);
break;
}
case sb_C_GETBASEBYTE: {
POP_SUBR_ARGS;
TopOfStack = get_c_basebyte(args);
break;
}
case sb_SMASHING_APPLY: {
POP_SUBR_ARGS;
TopOfStack = smashing_c_fn(args);
break;
}
#endif /* MAIKO_ENABLE_FOREIGN_FUNCTION_INTERFACE */
#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 */
case sb_YIELD: {
struct timespec rqts = {0, 833333};
unsigned sleepnanos;
POP_SUBR_ARGS;
N_GETNUMBER(args[0], sleepnanos, ret_nil);
if (sleepnanos > 999999999) {
TopOfStack = NIL;
break;
}
rqts.tv_nsec = sleepnanos;
nanosleep(&rqts, NULL);
TopOfStack = ATOM_T;
break;
}
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