Usenet 1994 January/usenetsourcesnewsgroupsinfomagicjanuary1994.iso/sources/unix/volume26/veos-2.0/part02

Text File | 1993-04-25 | 92.8 KB | 3,394 lines

Newsgroups: comp.sources.unix
From: [e-mail] (Geoffery Coco)
Subject: v26i185: veos-2.0 - The Virtual Environment Operating Shell, V2.0, Part02/16
Sender: [e-mail]
Approved: [e-mail]

Submitted-By: [e-mail] (Geoffery Coco)
Posting-Number: Volume 26, Issue 185
Archive-Name: veos-2.0/part02

#! /bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 2 (of 16)."
# Contents:  kernel_private/src/fern/fern.lsp
#   kernel_private/src/fern/local.lsp
#   kernel_private/src/include/xv_native.h
#   src/kernel_current/fern/fern.lsp src/kernel_current/fern/local.lsp
#   src/kernel_current/include/xv_native.h src/xlisp/xcore/c/xldbug.c
#   src/xlisp/xcore/c/xlglob.c src/xlisp/xcore/c/xlio.c
#   src/xlisp/xcore/c/xljump.c src/xlisp/xcore/c/xlpp.c
#   src/xlisp/xcore/c/xlsubr.c src/xlisp/xcore/c/xlsym.c
#   src/xlisp/xcore/c/xlsys.c src/xlisp/xcore/c/xmain.c
#   src/xlisp/xmodules.h
# Wrapped by [e-mail] on Sun Apr 25 23:10:32 1993
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'kernel_private/src/fern/fern.lsp' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'kernel_private/src/fern/fern.lsp'\"
else
echo shar: Extracting \"'kernel_private/src/fern/fern.lsp'\" \(5017 characters\)
sed "s/^X//" >'kernel_private/src/fern/fern.lsp' <<'END_OF_FILE'
X;;-----------------------------------------------------------
X;; file: fern.lsp
X;;
X;; FERN is the Fractal Entity Relativity Node.
X;; This file is the controller of the FERN compenents
X;;
X;; creation: February 28, 1992
X;;
X;; by Geoffrey P. Coco at the HITLab, Seattle
X;;-----------------------------------------------------------
X
X;;-----------------------------------------------------------
X;; Copyright (C) 1992  Geoffrey P. Coco,
X;; Human Interface Technology Lab, Seattle
X;;-----------------------------------------------------------
X
X
X;;-----------------------------------------------------------
X;;             Fern System
X;;-----------------------------------------------------------
X#|
X
XFern is a distributed world information management system.
XFern provides the transparent underpinnings for distributed
Xworld data maintenance.
X
XFern maintains a "perc" (e.g. perception) partition in an
Xentity's grouplespace (see below).  Fern transparently
Xupdates the "perc" partition of an entity's local
Xgrouplespace to contain all world data relevant to the
Xentity.
X
X("perc"
X
X    (;ext
X
X        (;sps (;ent))
X
X        (;sibs (;ent (;ob (;attr))))
X
X        (;fltrs)
X    )
X    (;bndry
X
X        (;vrt (;ob (;attr)))
X
X        (;phys (;ob (;attr)))
X    )
X    (;int
X
X        (;subs (;ent (;ob (;attr))))
X
X    (;fltrs (;ent))
X
X        (;locl (;ob (;attr)))
X    )
X)
X
XThe "perc" partition is accessable through fe- functions.
XUse fe- functions by composing the partition names you want
Xto access.  For example, if you want to change an attribute
Xin the virtual boundary, use (fe-put.bndry.vrt.ob.attr)
X
X|#
X;;-----------------------------------------------------------
X
X
X
X;;-----------------------------------------------------------
X;;             Fern Initialization
X;;-----------------------------------------------------------
X
X
X(defun fern-init ()
X  (progn
X
X    ;;;
X    ;;; init the VEOS kernel
X    ;;; watch out for previous initialization
X    ;;;
X
X    (let (zoot)
X      (cond ((setq zoot (vinit))
X         (setq self zoot))))
X
X    ;;;
X    ;;; other initial accounting
X    ;;;
X
X    (setq fern-debug t)
X
X
X    ;;;
X    ;;; initialize Fern System C module
X    ;;;
X
X    (fbase-init)
X
X
X    ;;;
X    ;;; load and initialize Fern System lisp modules
X    ;;;
X
X    (load "fgod")
X    (fgod-init)
X
X    (load "fe")
X    (fe-init)
X
X    (load "fx")
X    (fx-init)
X
X    (load "fcon")
X    (fcon-init)
X
X    (load "fph")
X    (fph-init)
X
X
X    ;;;
X    ;;; print fern header
X    ;;;
X
X    (fern-credits)
X    t))
X
X;;-----------------------------------------------------------
X
X
X
X;;-----------------------------------------------------------
X;;              Utilities
X;;-----------------------------------------------------------
X
X
X;;-----------------------------------------------------------
X
X(defun dump ()
X  (pprint (vcopy '(> @@))))
X
X(defun empty ()
X  (pprint (vget '(> @@))))
X
X(defmacro pp (expr) (pprint (eval expr)))
X
X;;-----------------------------------------------------------
X
X(defun uid2str (uid)
X  (sprintf (aref uid 0) " " (aref uid 1)))
X
X(defun str2uid (str)
X  (let ((lst (sscanf str)))
X    (vector (car lst) (cadr lst))))
X
X;;-----------------------------------------------------------
X
X(defun vect2list (vect)
X  (do ((ret NIL)
X       (index (1- (length vect))))
X
X      ((eq index -1)
X       ret)
X
X      (setq ret (cons (aref vect index) ret))
X      (setq index (1- index))
X      ))
X
X;;-----------------------------------------------------------
X
X(defun list2vect (lst)
X  (do* ((len (length lst))
X    (ret (make-array len))
X    (index 0))
X
X       ((eq index len)
X    ret)
X
X       (setf (aref ret index) (car lst))
X       (setq index (1+ index))
X       (setq lst (cdr lst))
X       ))
X
X;;-----------------------------------------------------------
X
X;; a partition looks like ("name" (everything))
X(defun put-gspace-partition (new-part)
X  (cond
X   ;; assume partition is already there
X   ((vput new-part `(> (,(car new-part) @@) **)))
X
X   ;; partition wasn't there, insert new
X   ((vput new-part '(^ @@)))))
X
X;; part name is a string
X(defun copy-gspace-partition (part-name)
X  (car (vcopy `(> (,part-name @@) **))))
X
X;; part name is a string
X(defun get-gspace-partition (part-name)
X  (car (vget `(> (,part-name @@) **))))
X
X;;-----------------------------------------------------------
X
X(defun do-procs (pro-list)
X  (dolist (proc pro-list)
X      (eval (cadr proc))))
X
X;;-----------------------------------------------------------
X
X
X
X
X;;-----------------------------------------------------------
X;;         Main Fern Private Functions
X;;-----------------------------------------------------------
X
X
X;;-----------------------------------------------------------
X(defun fern-credits ()
X  (printf "
X
X
X         ``````````````````````````
X           The Fern System v1.0b1
X                        by Geoff Coco
X          Copyright (C) 1992, HITL
X
X         ''''''''''''''''''''''''''
X"))
X
X;;-----------------------------------------------------------
X
X
X
X
X
X;;-----------------------------------------------------------
X;;            Invoke Initialization
X;;-----------------------------------------------------------
X
X(fern-init)
X
X
X
X
X
END_OF_FILE
if test 5017 -ne `wc -c <'kernel_private/src/fern/fern.lsp'`; then
    echo shar: \"'kernel_private/src/fern/fern.lsp'\" unpacked with wrong size!
fi
# end of 'kernel_private/src/fern/fern.lsp'
fi
if test -f 'kernel_private/src/fern/local.lsp' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'kernel_private/src/fern/local.lsp'\"
else
echo shar: Extracting \"'kernel_private/src/fern/local.lsp'\" \(5513 characters\)
sed "s/^X//" >'kernel_private/src/fern/local.lsp' <<'END_OF_FILE'
X;
X; local.lsp
X;
X; Copyright (C) 1992  Washington Technology Center
X;
X; by Andrew MacDonald at the HITLab
X;
X; object caching in the local workspace
X;
X; this is based on fe_bnd.lsp and fe_int.lsp, and manipulates objects
X; in perc.int.locl
X;
X; functions are of the form fe-(put|get|copy).int.locl.(accessors),
X; with macros of the form lo-(put|get|copy).(accessors) defined
X; for each function
X;
X;;-----------------------------------------------------------
X;; file: fe.lsp
X;; by Geoffrey P. Coco at the HITLab, Seattle
X;;-----------------------------------------------------------
X
X;;-----------------------------------------------------------
X;; Copyright (C) 1992  Human Interface Technology Lab, Seattle
X;;-----------------------------------------------------------
X
X
X;;===========================================================
X;;               Local Objects
X;;===========================================================
X
X(defun fe-jam.int.locl.ob (ob)
X  (vput ob
X    '(("perc"
X       @2
X       ((^ @@) @2)) **)))
X
X;;-----------------------------------------------------------
X
X;; objects are (ob-name (attr-list))
X(defun fe-put.int.locl.ob (ob)
X  (cond
X
X   ;; assume object is already there
X   ((car (vput ob `(("perc"
X             @2
X             ((> (,(car ob) @) **) @2)) **))))
X
X   ;; object wasn't there, insert new one
X   ((fe-jam.int.locl.ob ob))
X   ))
X
X;;-----------------------------------------------------------
X
X;; pass object name
X(defun fe-copy.int.locl.ob (ob-name)
X  (car (vcopy `(("perc"
X         @2
X         ((> (,ob-name @) **) @2)) **))))
X
X;;-----------------------------------------------------------
X
X;; pass object name, returns entire object
X(defun fe-get.int.locl.ob (ob-name)
X  (car (vget `(("perc"
X        @2
X        ((> (,ob-name @) **) @2)) **))))
X
X;;-----------------------------------------------------------
X
X
X
X;;===========================================================
X;;          Local Object - Complex
X;;===========================================================
X
X(defun fe-copy.int.locl.ob.names ()
X  (vcopy `(("perc"
X        @2
X        (((> @ @) **) @2)) **)
X     :freq "all"))
X
X;;-----------------------------------------------------------
X
X
X
X
X;;===========================================================
X;;          Local Object Attributes
X;;===========================================================
X
X(defun fe-jam.int.locl.ob.attr (ob-name attr)
X  (cond
X   ;; assume object exists, add new attr
X   ((vput attr `(("perc"
X          @2
X          (((,ob-name (^ @@)) **) @2)) **)))
X
X   ;; object didn't exist, add new object with new attr.
X   ((fe-jam.int.locl.ob `(,ob-name (,attr))))
X   ))
X
X;;-----------------------------------------------------------
X
X(defun fe-put.int.locl.ob.attr (ob-name attr)
X  (cond
X
X   ;; assume the object and attr exist, swap in new attr
X   ((car (vput attr `(("perc"
X               @2
X               (((,ob-name (> (,(car attr) @) **)) **) @2)) **))))
X
X   ;; attr didn't exist, add new attr
X   ((fe-jam.int.locl.ob.attr ob-name attr))
X   ))
X
X;;-----------------------------------------------------------
X
X(defun fe-get.int.locl.ob.attr (ob-name attr-name)
X  (car (vget `(("perc"
X        @2
X        (((,ob-name (> (,attr-name @) **)) **) @2)) **))))
X
X;;-----------------------------------------------------------
X
X;; returns attr struct
X(defun fe-copy.int.locl.ob.attr (ob-name attr-name)
X  (car (vcopy `(("perc"
X         @2
X         (((,ob-name (> (,attr-name @) **)) **) @2)) **))))
X
X;;-----------------------------------------------------------
X
X
X
X;;===========================================================
X;;         Local Object Attributes - Complex
X;;===========================================================
X
X;; returns list of boundary attribute names
X(defun fe-copy.int.locl.ob.attr.names (ob-name)
X  (vcopy `(("perc"
X        @2
X        (((,ob-name ((> @ @) **)) **) @2)) **)
X     :freq "all"))
X
X;;-----------------------------------------------------------
X
X;; returns attr val
X(defun fe-copy.int.locl.ob.attr.val (ob-name attr-name)
X  (car (vcopy `(("perc"
X         @2
X         (((,ob-name ((,attr-name > @) **)) **) @2)) **))))
X
X;;===========================================================
X;;         Show Local Object Space
X;;===========================================================
X
X(defun lo-dump ()
X  (pprint (fe-copy.int.locl)))
X
X(defun lo-empty ()
X  (pprint (fe-get.int.locl)))
X
X;;===========================================================
X;;         Macro Shortcuts
X;;===========================================================
X
X(defmacro lo-jam-ob (ob)
X  `(fe-jam.int.locl.ob ,ob))
X
X(defmacro lo-put-ob (ob)
X  `(fe-put.int.locl.ob ,ob))
X
X(defmacro lo-copy-ob (ob-name)
X  `(fe-copy.int.locl.ob ,ob-name))
X
X(defmacro lo-get-ob (ob-name)
X  `(fe-get.int.locl.ob ,ob-name))
X
X;----------------------------------------------------------------
X
X(defmacro lo-copy-ob-names ()
X  '(fe-copy.int.locl.ob.names))
X
X;----------------------------------------------------------------
X
X(defmacro lo-jab-attr (ob-name attr)
X  `(fe-jam.int.locl.ob.attr ,ob-name ,attr))
X
X(defmacro lo-put-attr (ob-name attr)
X  `(fe-put.int.locl.ob.attr ,ob-name ,attr))
X
X;----------------------------------------------------------------
X
X(defmacro lo-get-attr (ob-name attr-name)
X  `(fe-get.int.locl.ob.attr ,ob-name ,attr-name))
X
X;----------------------------------------------------------------
X
X(defmacro lo-copy-attr (ob-name attr-name)
X  `(fe-copy.int.locl.ob.attr ,ob-name ,attr-name))
X
X(defmacro lo-copy-attr-names (ob-name)
X  `(fe-copy.int.locl.ob.attr.names ,ob-name))
X
X(defmacro lo-copy-attr-val (ob-name attr-name)
X  `(fe-copy.int.locl.ob.attr.val ,ob-name ,attr-name))
X
END_OF_FILE
if test 5513 -ne `wc -c <'kernel_private/src/fern/local.lsp'`; then
    echo shar: \"'kernel_private/src/fern/local.lsp'\" unpacked with wrong size!
fi
# end of 'kernel_private/src/fern/local.lsp'
fi
if test -f 'kernel_private/src/include/xv_native.h' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'kernel_private/src/include/xv_native.h'\"
else
echo shar: Extracting \"'kernel_private/src/include/xv_native.h'\" \(3846 characters\)
sed "s/^X//" >'kernel_private/src/include/xv_native.h' <<'END_OF_FILE'
X/****************************************************************************************
X *                                            *
X * file: xv_native.h                                    *
X *                                            *
X * the xlisp include file for integration with VEOS native prims.            *
X *                                            *
X * creation: December, 1991                                *
X *                                            *
X *                                            *
X * by Geoffrey P. Coco at the HITLab, Seattle.                          *
X *                                            *
X ****************************************************************************************/
X
X/****************************************************************************************
X * Copyright (C) 1992  Geoffrey P. Coco, Human Interface Technology Lab, Seattle    *
X ****************************************************************************************/
X
X
X#ifdef DEFINE_NATIVE_GLOBS
X#define NEXTERN
X#else
X#define NEXTERN extern
X#endif
X
X/****************************************************************************************/
X
X
X/****************************************************************************************/
X
Xtypedef struct {
X
X    TPGrouple        pSrcGr;        /* the actual src data */
X    TPGrouple        pPatGr;        /* how to match */
X    int            iDestroyFlag;    /* copy, remove, gimme, replace */
X    int            iFreqFlag;    /* once or all occasions */
X
X    LVAL        pXReplaceElt;    /* possible replacement data */
X    TPTimeStamp        pStampTime;    /* optional time to stamp new data */
X    TPTimeStamp        pTestTime;    /* optional time to compare with matched data */
X    LVAL        pXResult;    /* result data to pass back */
X
X    } TXMandRRec,
X      *TPXMandRRec,
X      **THXMandRRec;
X
X
Xtypedef struct {
X    boolean    bOrdered;
X    boolean    bExpContent;
X    boolean    bExpOrder;
X    boolean    bMarkedWithin;
X    boolean    bTouchedWithin;
X
X    boolean    bMarkNextElt;
X    boolean    bTouchNextElt;
X    boolean    bMustEnd;
X    boolean    bGetAnother;
X
X    } TPatStatRec,
X      *TPPatStatRec,
X      **THPatStatRec;
X
X/****************************************************************************************/
X
X#define NATIVE_BADTYPE        -10
X#define NATIVE_NOKERNEL        -11
X#define NATIVE_BADFREQ        -12
X#define NATIVE_2KERNELS        -13
X#define NATIVE_BADVTYPE        -14
X#define NATIVE_THISWHAT        -15
X#define NATIVE_TOOMANYMARKS    -16
X#define NATIVE_CANTMIX        -17
X#define NATIVE_NOREPLACEMARK    -18
X#define NATIVE_NOFETCHMARK    -19
X#define NATIVE_NOVOID        -20
X#define NATIVE_BADPATSYMBOL    -21
X#define NATIVE_CRAZYWILD    -22
X#define NATIVE_MATCHFAIL    -23
X#define NATIVE_NODATA        -24
X#define NATIVE_EMPTYELT        -25
X#define NATIVE_STARMORE        -26
X#define NATIVE_NOTEND        -27
X#define NATIVE_BADVOID        -28
X#define NATIVE_NOSTARN        -29
X#define NATIVE_BADXTYPE        -30
X#define NATIVE_NOHOST        -31
X#define NATIVE_NOTOUCH        -32
X#define NATIVE_MODVOID        -33
X
X#define NATIVE_SYMBOL        10
X#define NATIVE_STALE        -40
X
X/****************************************************************************************/
X
Xextern LVAL     xsendmsg0();
Xextern LVAL    s_unbound;
Xextern LVAL    true;
Xextern LVAL     xlfatal();
Xextern LVAL    s_stderr;
X
X/****************************************************************************************/
X
XNEXTERN LVAL        s_InSpace, k_TestTime, k_Freq;
XNEXTERN LVAL           *hMsgList;
XNEXTERN TXMandRRec    native_getPB, native_copyPB, native_putPB;
X
X/****************************************************************************************/
X
X#define NATIVE_INSPACE hMsgList
X
X#define NATIVE_TIME_ARG(pTime, tTest) \
X{ \
X    LVAL        pXTime; \
X    TTimeStamp        tRead; \
X\
X    if (xlgetkeyarg(k_TestTime, &pXTime) && !null(pXTime)) { \
X    XELT2TIME(pXTime, tTest); \
X    pTime = &tTest; \
X\
X    GET_TIME(tRead); \
X    TIME2XELT(tRead, pXTime); \
X    } \
X    else \
X    pTime = nil; \
X    }
X
X
X#define NATIVE_FREQ_ARG(iFlag) \
X{ \
X    LVAL    pXFreq; \
X\
X    if (xlgetkeyarg(k_Freq, &pXFreq) && \
X    (strcmp((char *)getstring(pXFreq), "all") == 0)) \
X    iFlag = NANCY_MatchMany; \
X    else \
X    iFlag = NANCY_MatchOne; \
X    }
X
X/****************************************************************************************/
X
X
END_OF_FILE
if test 3846 -ne `wc -c <'kernel_private/src/include/xv_native.h'`; then
    echo shar: \"'kernel_private/src/include/xv_native.h'\" unpacked with wrong size!
fi
# end of 'kernel_private/src/include/xv_native.h'
fi
if test -f 'src/kernel_current/fern/fern.lsp' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/kernel_current/fern/fern.lsp'\"
else
echo shar: Extracting \"'src/kernel_current/fern/fern.lsp'\" \(5017 characters\)
sed "s/^X//" >'src/kernel_current/fern/fern.lsp' <<'END_OF_FILE'
X;;-----------------------------------------------------------
X;; file: fern.lsp
X;;
X;; FERN is the Fractal Entity Relativity Node.
X;; This file is the controller of the FERN compenents
X;;
X;; creation: February 28, 1992
X;;
X;; by Geoffrey P. Coco at the HITLab, Seattle
X;;-----------------------------------------------------------
X
X;;-----------------------------------------------------------
X;; Copyright (C) 1992  Geoffrey P. Coco,
X;; Human Interface Technology Lab, Seattle
X;;-----------------------------------------------------------
X
X
X;;-----------------------------------------------------------
X;;             Fern System
X;;-----------------------------------------------------------
X#|
X
XFern is a distributed world information management system.
XFern provides the transparent underpinnings for distributed
Xworld data maintenance.
X
XFern maintains a "perc" (e.g. perception) partition in an
Xentity's grouplespace (see below).  Fern transparently
Xupdates the "perc" partition of an entity's local
Xgrouplespace to contain all world data relevant to the
Xentity.
X
X("perc"
X
X    (;ext
X
X        (;sps (;ent))
X
X        (;sibs (;ent (;ob (;attr))))
X
X        (;fltrs)
X    )
X    (;bndry
X
X        (;vrt (;ob (;attr)))
X
X        (;phys (;ob (;attr)))
X    )
X    (;int
X
X        (;subs (;ent (;ob (;attr))))
X
X    (;fltrs (;ent))
X
X        (;locl (;ob (;attr)))
X    )
X)
X
XThe "perc" partition is accessable through fe- functions.
XUse fe- functions by composing the partition names you want
Xto access.  For example, if you want to change an attribute
Xin the virtual boundary, use (fe-put.bndry.vrt.ob.attr)
X
X|#
X;;-----------------------------------------------------------
X
X
X
X;;-----------------------------------------------------------
X;;             Fern Initialization
X;;-----------------------------------------------------------
X
X
X(defun fern-init ()
X  (progn
X
X    ;;;
X    ;;; init the VEOS kernel
X    ;;; watch out for previous initialization
X    ;;;
X
X    (let (zoot)
X      (cond ((setq zoot (vinit))
X         (setq self zoot))))
X
X    ;;;
X    ;;; other initial accounting
X    ;;;
X
X    (setq fern-debug t)
X
X
X    ;;;
X    ;;; initialize Fern System C module
X    ;;;
X
X    (fbase-init)
X
X
X    ;;;
X    ;;; load and initialize Fern System lisp modules
X    ;;;
X
X    (load "fgod")
X    (fgod-init)
X
X    (load "fe")
X    (fe-init)
X
X    (load "fx")
X    (fx-init)
X
X    (load "fcon")
X    (fcon-init)
X
X    (load "fph")
X    (fph-init)
X
X
X    ;;;
X    ;;; print fern header
X    ;;;
X
X    (fern-credits)
X    t))
X
X;;-----------------------------------------------------------
X
X
X
X;;-----------------------------------------------------------
X;;              Utilities
X;;-----------------------------------------------------------
X
X
X;;-----------------------------------------------------------
X
X(defun dump ()
X  (pprint (vcopy '(> @@))))
X
X(defun empty ()
X  (pprint (vget '(> @@))))
X
X(defmacro pp (expr) (pprint (eval expr)))
X
X;;-----------------------------------------------------------
X
X(defun uid2str (uid)
X  (sprintf (aref uid 0) " " (aref uid 1)))
X
X(defun str2uid (str)
X  (let ((lst (sscanf str)))
X    (vector (car lst) (cadr lst))))
X
X;;-----------------------------------------------------------
X
X(defun vect2list (vect)
X  (do ((ret NIL)
X       (index (1- (length vect))))
X
X      ((eq index -1)
X       ret)
X
X      (setq ret (cons (aref vect index) ret))
X      (setq index (1- index))
X      ))
X
X;;-----------------------------------------------------------
X
X(defun list2vect (lst)
X  (do* ((len (length lst))
X    (ret (make-array len))
X    (index 0))
X
X       ((eq index len)
X    ret)
X
X       (setf (aref ret index) (car lst))
X       (setq index (1+ index))
X       (setq lst (cdr lst))
X       ))
X
X;;-----------------------------------------------------------
X
X;; a partition looks like ("name" (everything))
X(defun put-gspace-partition (new-part)
X  (cond
X   ;; assume partition is already there
X   ((vput new-part `(> (,(car new-part) @@) **)))
X
X   ;; partition wasn't there, insert new
X   ((vput new-part '(^ @@)))))
X
X;; part name is a string
X(defun copy-gspace-partition (part-name)
X  (car (vcopy `(> (,part-name @@) **))))
X
X;; part name is a string
X(defun get-gspace-partition (part-name)
X  (car (vget `(> (,part-name @@) **))))
X
X;;-----------------------------------------------------------
X
X(defun do-procs (pro-list)
X  (dolist (proc pro-list)
X      (eval (cadr proc))))
X
X;;-----------------------------------------------------------
X
X
X
X
X;;-----------------------------------------------------------
X;;         Main Fern Private Functions
X;;-----------------------------------------------------------
X
X
X;;-----------------------------------------------------------
X(defun fern-credits ()
X  (printf "
X
X
X         ``````````````````````````
X           The Fern System v1.0b1
X                        by Geoff Coco
X          Copyright (C) 1992, HITL
X
X         ''''''''''''''''''''''''''
X"))
X
X;;-----------------------------------------------------------
X
X
X
X
X
X;;-----------------------------------------------------------
X;;            Invoke Initialization
X;;-----------------------------------------------------------
X
X(fern-init)
X
X
X
X
X
END_OF_FILE
if test 5017 -ne `wc -c <'src/kernel_current/fern/fern.lsp'`; then
    echo shar: \"'src/kernel_current/fern/fern.lsp'\" unpacked with wrong size!
fi
# end of 'src/kernel_current/fern/fern.lsp'
fi
if test -f 'src/kernel_current/fern/local.lsp' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/kernel_current/fern/local.lsp'\"
else
echo shar: Extracting \"'src/kernel_current/fern/local.lsp'\" \(5513 characters\)
sed "s/^X//" >'src/kernel_current/fern/local.lsp' <<'END_OF_FILE'
X;
X; local.lsp
X;
X; Copyright (C) 1992  Washington Technology Center
X;
X; by Andrew MacDonald at the HITLab
X;
X; object caching in the local workspace
X;
X; this is based on fe_bnd.lsp and fe_int.lsp, and manipulates objects
X; in perc.int.locl
X;
X; functions are of the form fe-(put|get|copy).int.locl.(accessors),
X; with macros of the form lo-(put|get|copy).(accessors) defined
X; for each function
X;
X;;-----------------------------------------------------------
X;; file: fe.lsp
X;; by Geoffrey P. Coco at the HITLab, Seattle
X;;-----------------------------------------------------------
X
X;;-----------------------------------------------------------
X;; Copyright (C) 1992  Human Interface Technology Lab, Seattle
X;;-----------------------------------------------------------
X
X
X;;===========================================================
X;;               Local Objects
X;;===========================================================
X
X(defun fe-jam.int.locl.ob (ob)
X  (vput ob
X    '(("perc"
X       @2
X       ((^ @@) @2)) **)))
X
X;;-----------------------------------------------------------
X
X;; objects are (ob-name (attr-list))
X(defun fe-put.int.locl.ob (ob)
X  (cond
X
X   ;; assume object is already there
X   ((car (vput ob `(("perc"
X             @2
X             ((> (,(car ob) @) **) @2)) **))))
X
X   ;; object wasn't there, insert new one
X   ((fe-jam.int.locl.ob ob))
X   ))
X
X;;-----------------------------------------------------------
X
X;; pass object name
X(defun fe-copy.int.locl.ob (ob-name)
X  (car (vcopy `(("perc"
X         @2
X         ((> (,ob-name @) **) @2)) **))))
X
X;;-----------------------------------------------------------
X
X;; pass object name, returns entire object
X(defun fe-get.int.locl.ob (ob-name)
X  (car (vget `(("perc"
X        @2
X        ((> (,ob-name @) **) @2)) **))))
X
X;;-----------------------------------------------------------
X
X
X
X;;===========================================================
X;;          Local Object - Complex
X;;===========================================================
X
X(defun fe-copy.int.locl.ob.names ()
X  (vcopy `(("perc"
X        @2
X        (((> @ @) **) @2)) **)
X     :freq "all"))
X
X;;-----------------------------------------------------------
X
X
X
X
X;;===========================================================
X;;          Local Object Attributes
X;;===========================================================
X
X(defun fe-jam.int.locl.ob.attr (ob-name attr)
X  (cond
X   ;; assume object exists, add new attr
X   ((vput attr `(("perc"
X          @2
X          (((,ob-name (^ @@)) **) @2)) **)))
X
X   ;; object didn't exist, add new object with new attr.
X   ((fe-jam.int.locl.ob `(,ob-name (,attr))))
X   ))
X
X;;-----------------------------------------------------------
X
X(defun fe-put.int.locl.ob.attr (ob-name attr)
X  (cond
X
X   ;; assume the object and attr exist, swap in new attr
X   ((car (vput attr `(("perc"
X               @2
X               (((,ob-name (> (,(car attr) @) **)) **) @2)) **))))
X
X   ;; attr didn't exist, add new attr
X   ((fe-jam.int.locl.ob.attr ob-name attr))
X   ))
X
X;;-----------------------------------------------------------
X
X(defun fe-get.int.locl.ob.attr (ob-name attr-name)
X  (car (vget `(("perc"
X        @2
X        (((,ob-name (> (,attr-name @) **)) **) @2)) **))))
X
X;;-----------------------------------------------------------
X
X;; returns attr struct
X(defun fe-copy.int.locl.ob.attr (ob-name attr-name)
X  (car (vcopy `(("perc"
X         @2
X         (((,ob-name (> (,attr-name @) **)) **) @2)) **))))
X
X;;-----------------------------------------------------------
X
X
X
X;;===========================================================
X;;         Local Object Attributes - Complex
X;;===========================================================
X
X;; returns list of boundary attribute names
X(defun fe-copy.int.locl.ob.attr.names (ob-name)
X  (vcopy `(("perc"
X        @2
X        (((,ob-name ((> @ @) **)) **) @2)) **)
X     :freq "all"))
X
X;;-----------------------------------------------------------
X
X;; returns attr val
X(defun fe-copy.int.locl.ob.attr.val (ob-name attr-name)
X  (car (vcopy `(("perc"
X         @2
X         (((,ob-name ((,attr-name > @) **)) **) @2)) **))))
X
X;;===========================================================
X;;         Show Local Object Space
X;;===========================================================
X
X(defun lo-dump ()
X  (pprint (fe-copy.int.locl)))
X
X(defun lo-empty ()
X  (pprint (fe-get.int.locl)))
X
X;;===========================================================
X;;         Macro Shortcuts
X;;===========================================================
X
X(defmacro lo-jam-ob (ob)
X  `(fe-jam.int.locl.ob ,ob))
X
X(defmacro lo-put-ob (ob)
X  `(fe-put.int.locl.ob ,ob))
X
X(defmacro lo-copy-ob (ob-name)
X  `(fe-copy.int.locl.ob ,ob-name))
X
X(defmacro lo-get-ob (ob-name)
X  `(fe-get.int.locl.ob ,ob-name))
X
X;----------------------------------------------------------------
X
X(defmacro lo-copy-ob-names ()
X  '(fe-copy.int.locl.ob.names))
X
X;----------------------------------------------------------------
X
X(defmacro lo-jab-attr (ob-name attr)
X  `(fe-jam.int.locl.ob.attr ,ob-name ,attr))
X
X(defmacro lo-put-attr (ob-name attr)
X  `(fe-put.int.locl.ob.attr ,ob-name ,attr))
X
X;----------------------------------------------------------------
X
X(defmacro lo-get-attr (ob-name attr-name)
X  `(fe-get.int.locl.ob.attr ,ob-name ,attr-name))
X
X;----------------------------------------------------------------
X
X(defmacro lo-copy-attr (ob-name attr-name)
X  `(fe-copy.int.locl.ob.attr ,ob-name ,attr-name))
X
X(defmacro lo-copy-attr-names (ob-name)
X  `(fe-copy.int.locl.ob.attr.names ,ob-name))
X
X(defmacro lo-copy-attr-val (ob-name attr-name)
X  `(fe-copy.int.locl.ob.attr.val ,ob-name ,attr-name))
X
END_OF_FILE
if test 5513 -ne `wc -c <'src/kernel_current/fern/local.lsp'`; then
    echo shar: \"'src/kernel_current/fern/local.lsp'\" unpacked with wrong size!
fi
# end of 'src/kernel_current/fern/local.lsp'
fi
if test -f 'src/kernel_current/include/xv_native.h' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/kernel_current/include/xv_native.h'\"
else
echo shar: Extracting \"'src/kernel_current/include/xv_native.h'\" \(3846 characters\)
sed "s/^X//" >'src/kernel_current/include/xv_native.h' <<'END_OF_FILE'
X/****************************************************************************************
X *                                            *
X * file: xv_native.h                                    *
X *                                            *
X * the xlisp include file for integration with VEOS native prims.            *
X *                                            *
X * creation: December, 1991                                *
X *                                            *
X *                                            *
X * by Geoffrey P. Coco at the HITLab, Seattle.                          *
X *                                            *
X ****************************************************************************************/
X
X/****************************************************************************************
X * Copyright (C) 1992  Geoffrey P. Coco, Human Interface Technology Lab, Seattle    *
X ****************************************************************************************/
X
X
X#ifdef DEFINE_NATIVE_GLOBS
X#define NEXTERN
X#else
X#define NEXTERN extern
X#endif
X
X/****************************************************************************************/
X
X
X/****************************************************************************************/
X
Xtypedef struct {
X
X    TPGrouple        pSrcGr;        /* the actual src data */
X    TPGrouple        pPatGr;        /* how to match */
X    int            iDestroyFlag;    /* copy, remove, gimme, replace */
X    int            iFreqFlag;    /* once or all occasions */
X
X    LVAL        pXReplaceElt;    /* possible replacement data */
X    TPTimeStamp        pStampTime;    /* optional time to stamp new data */
X    TPTimeStamp        pTestTime;    /* optional time to compare with matched data */
X    LVAL        pXResult;    /* result data to pass back */
X
X    } TXMandRRec,
X      *TPXMandRRec,
X      **THXMandRRec;
X
X
Xtypedef struct {
X    boolean    bOrdered;
X    boolean    bExpContent;
X    boolean    bExpOrder;
X    boolean    bMarkedWithin;
X    boolean    bTouchedWithin;
X
X    boolean    bMarkNextElt;
X    boolean    bTouchNextElt;
X    boolean    bMustEnd;
X    boolean    bGetAnother;
X
X    } TPatStatRec,
X      *TPPatStatRec,
X      **THPatStatRec;
X
X/****************************************************************************************/
X
X#define NATIVE_BADTYPE        -10
X#define NATIVE_NOKERNEL        -11
X#define NATIVE_BADFREQ        -12
X#define NATIVE_2KERNELS        -13
X#define NATIVE_BADVTYPE        -14
X#define NATIVE_THISWHAT        -15
X#define NATIVE_TOOMANYMARKS    -16
X#define NATIVE_CANTMIX        -17
X#define NATIVE_NOREPLACEMARK    -18
X#define NATIVE_NOFETCHMARK    -19
X#define NATIVE_NOVOID        -20
X#define NATIVE_BADPATSYMBOL    -21
X#define NATIVE_CRAZYWILD    -22
X#define NATIVE_MATCHFAIL    -23
X#define NATIVE_NODATA        -24
X#define NATIVE_EMPTYELT        -25
X#define NATIVE_STARMORE        -26
X#define NATIVE_NOTEND        -27
X#define NATIVE_BADVOID        -28
X#define NATIVE_NOSTARN        -29
X#define NATIVE_BADXTYPE        -30
X#define NATIVE_NOHOST        -31
X#define NATIVE_NOTOUCH        -32
X#define NATIVE_MODVOID        -33
X
X#define NATIVE_SYMBOL        10
X#define NATIVE_STALE        -40
X
X/****************************************************************************************/
X
Xextern LVAL     xsendmsg0();
Xextern LVAL    s_unbound;
Xextern LVAL    true;
Xextern LVAL     xlfatal();
Xextern LVAL    s_stderr;
X
X/****************************************************************************************/
X
XNEXTERN LVAL        s_InSpace, k_TestTime, k_Freq;
XNEXTERN LVAL           *hMsgList;
XNEXTERN TXMandRRec    native_getPB, native_copyPB, native_putPB;
X
X/****************************************************************************************/
X
X#define NATIVE_INSPACE hMsgList
X
X#define NATIVE_TIME_ARG(pTime, tTest) \
X{ \
X    LVAL        pXTime; \
X    TTimeStamp        tRead; \
X\
X    if (xlgetkeyarg(k_TestTime, &pXTime) && !null(pXTime)) { \
X    XELT2TIME(pXTime, tTest); \
X    pTime = &tTest; \
X\
X    GET_TIME(tRead); \
X    TIME2XELT(tRead, pXTime); \
X    } \
X    else \
X    pTime = nil; \
X    }
X
X
X#define NATIVE_FREQ_ARG(iFlag) \
X{ \
X    LVAL    pXFreq; \
X\
X    if (xlgetkeyarg(k_Freq, &pXFreq) && \
X    (strcmp((char *)getstring(pXFreq), "all") == 0)) \
X    iFlag = NANCY_MatchMany; \
X    else \
X    iFlag = NANCY_MatchOne; \
X    }
X
X/****************************************************************************************/
X
X
END_OF_FILE
if test 3846 -ne `wc -c <'src/kernel_current/include/xv_native.h'`; then
    echo shar: \"'src/kernel_current/include/xv_native.h'\" unpacked with wrong size!
fi
# end of 'src/kernel_current/include/xv_native.h'
fi
if test -f 'src/xlisp/xcore/c/xldbug.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xldbug.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xldbug.c'\" \(6382 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xldbug.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xldebug.c
X* RCS:          $Header: xldbug.c,v 1.4 90/08/07 16:32:28 mayer Exp $
X* Description:  xlisp debugging support
X* Author:       David Michael Betz; Niels Mayer
X* Created:
X* Modified:     Tue Aug  7 16:32:16 1990 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
Xstatic char rcs_identity[] = "@(#)$Header: xldbug.c,v 1.4 90/08/07 16:32:28 mayer Exp $";
X
X#include "xlisp.h"
X
X/* external variables */
Xextern int xldebug;
Xextern int xlsample;
Xextern LVAL s_debugio,s_unbound;
Xextern LVAL s_tracenable,s_tlimit,s_breakenable;
Xextern LVAL true;
Xextern char buf[];
X
X/* external routines */
Xextern char *malloc();
X
X/* forward declarations */
XFORWARD LVAL stacktop();
X
X/* xlabort - xlisp serious error handler */
Xxlabort(emsg)
X  char *emsg;
X{
X    xlsignal(emsg,s_unbound);
X    xlerrprint("error",NULL,emsg,s_unbound);
X    xlbrklevel();
X}
X
X/* xlbreak - enter a break loop */
Xxlbreak(emsg,arg)
X  char *emsg; LVAL arg;
X{
X    breakloop("break","return from BREAK",emsg,arg,TRUE);
X}
X
X/* xlfail - xlisp error handler */
Xxlfail(emsg)
X  char *emsg;
X{
X    xlerror(emsg,s_unbound);
X}
X
X/* xlerror - handle a fatal error */
X#ifdef BOGUS
Xstatic xlerror_zero = 0;
X#endif
Xxlerror(emsg,arg)
X  char *emsg; LVAL arg;
X{
X#ifdef BOGUS
Xprintf( "\ncrashing in xlerror, emsg s= '%s'", emsg );
Xprintf( "\ndummy printf %x, %x", 1 / xlerror_zero, *(int*)xlerror_zero );
X#endif
X    if (getvalue(s_breakenable) != NIL) {
X    breakloop("error",NULL,emsg,arg,FALSE);
X    } else {
X    xlsignal(emsg,arg);
X    xlerrprint("error",NULL,emsg,arg);
X    xlbrklevel();
X    }
X}
X
X/* xlcerror - handle a recoverable error */
Xxlcerror(cmsg,emsg,arg)
X  char *cmsg,*emsg; LVAL arg;
X{
X    if (getvalue(s_breakenable) != NIL)
X    breakloop("error",cmsg,emsg,arg,TRUE);
X    else {
X    xlsignal(emsg,arg);
X    xlerrprint("error",NULL,emsg,arg);
X    xlbrklevel();
X    }
X}
X
X/* xlerrprint - print an error message */
Xxlerrprint(hdr,cmsg,emsg,arg)
X  char *hdr,*cmsg,*emsg; LVAL arg;
X{
X    /* print the error message */
X    sprintf(buf,"%s: %s",hdr,emsg);
X    errputstr(buf);
X
X    /* print the argument */
X    if (arg != s_unbound) {
X    errputstr(" - ");
X    errprint(arg);
X    }
X
X    /* no argument, just end the line */
X    else
X    errputstr("\n");
X
X    /* print the continuation message */
X    if (cmsg) {
X    sprintf(buf,"if continued: %s\n",cmsg);
X    errputstr(buf);
X    }
X}
X
X#ifdef NEED_TO_REPLACE_BREAKLOOP
X/* Include hybrid-class functions: *//* JSP */
X#define MODULE_XLDBUG_C_BREAKLOOP_REPLACEMENT
X#include "../../xmodules.h"
X#undef MODULE_XLDBUG_C_BREAKLOOP_REPLACEMENT
X#else
X
X/* breakloop - the debug read-eval-print loop */
XLOCAL int breakloop(hdr,cmsg,emsg,arg,cflag)
X  char *hdr,*cmsg,*emsg; LVAL arg; int cflag;
X{
X    LVAL expr,val;
X    CONTEXT cntxt;
X    int type;
X
X    /* print the error message */
X    xlerrprint(hdr,cmsg,emsg,arg);
X
X    /* flush the input buffer */
X    xlflush();
X
X    /* do the back trace */
X    if (getvalue(s_tracenable)) {
X    val = getvalue(s_tlimit);
X    xlbaktrace(fixp(val) ? (int)getfixnum(val) : -1);
X    }
X
X    /* protect some pointers */
X    xlsave1(expr);
X
X    /* increment the debug level */
X    ++xldebug;
X
X    /* debug command processing loop */
X    xlbegin(&cntxt,CF_BRKLEVEL|CF_CLEANUP|CF_CONTINUE,true);
X    for (type = 0; type == 0; ) {
X
X    /* setup the continue trap */
X    if (type = xlsetjmp(cntxt.c_jmpbuf))
X        switch (type) {
X        case CF_CLEANUP:
X        continue;
X        case CF_BRKLEVEL:
X        type = 0;
X        break;
X        case CF_CONTINUE:
X        if (cflag) {
X            dbgputstr("[ continue from break loop ]\n");
X            continue;
X        }
X        else xlabort("this error can't be continued");
X        }
X
X    /* print a prompt */
X    sprintf(buf,"%d> ",xldebug);
X    dbgputstr(buf);
X
X    /* read an expression and check for eof */
X    if (!xlread(getvalue(s_debugio),&expr,FALSE)) {
X        type = CF_CLEANUP;
X        break;
X    }
X
X    /* save the input expression */
X    xlrdsave(expr);
X
X    /* evaluate the expression */
X    expr = xleval(expr);
X
X    /* save the result */
X    xlevsave(expr);
X
X    /* print it */
X    dbgprint(expr);
X    }
X    xlend(&cntxt);
X
X    /* decrement the debug level */
X    --xldebug;
X
X    /* restore the stack */
X    xlpop();
X
X    /* check for aborting to the previous level */
X    if (type == CF_CLEANUP)
X    xlbrklevel();
X}
X
X#endif
X
X/* baktrace - do a back trace */
Xxlbaktrace(n)
X  int n;
X{
X    LVAL *fp,*p;
X    int argc;
X    for (fp = xlfp; (n < 0 || n--) && *fp; fp = fp - (int)getfixnum(*fp)) {
X    p = fp + 1;
X    errputstr("Function: ");
X    errprint(*p++);
X    if (argc = (int)getfixnum(*p++))
X        errputstr("Arguments:\n");
X    while (--argc >= 0) {
X        errputstr("  ");
X        errprint(*p++);
X    }
X    }
X}
X
X/* xldinit - debug initialization routine */
Xxldinit()
X{
X    xlsample = 0;
X    xldebug = 0;
X}
X
END_OF_FILE
if test 6382 -ne `wc -c <'src/xlisp/xcore/c/xldbug.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xldbug.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xldbug.c'
fi
if test -f 'src/xlisp/xcore/c/xlglob.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlglob.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xlglob.c'\" \(4866 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xlglob.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xlglobals.c
X* RCS:          $Header: xlglob.c,v 1.4 89/11/25 05:30:06 mayer Exp $
X* Description:  xlisp global variables
X* Author:       David Michael Betz
X* Created:
X* Modified:     Sat Nov 25 05:29:22 1989 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
Xstatic char rcs_identity[] = "@(#)$Header: xlglob.c,v 1.4 89/11/25 05:30:06 mayer Exp $";
X
X
X#include "xlisp.h"
X
X/* symbols */
XLVAL true=NIL,obarray=NIL;
XLVAL s_unbound=NIL,s_dot=NIL;
XLVAL s_quote=NIL,s_function=NIL;
XLVAL s_bquote=NIL,s_comma=NIL,s_comat=NIL;
XLVAL s_evalhook=NIL,s_applyhook=NIL,s_tracelist;
XLVAL s_lambda=NIL,s_macro=NIL;
XLVAL s_send=NIL; /*91Jun15jsp*/
XLVAL s_stdin=NIL,s_stdout=NIL,s_stderr=NIL,s_debugio=NIL,s_traceout=NIL;
XLVAL s_rtable=NIL;
XLVAL s_tracenable=NIL,s_tlimit=NIL,s_breakenable=NIL;
XLVAL s_setf=NIL,s_car=NIL,s_cdr=NIL,s_nth=NIL,s_aref=NIL,s_get=NIL;
XLVAL s_svalue=NIL,s_sfunction=NIL,s_splist=NIL;
XLVAL s_eql=NIL,s_gcflag=NIL,s_gchook=NIL;
XLVAL s_ifmt=NIL,s_ffmt=NIL;
XLVAL s_1plus=NIL,s_2plus=NIL,s_3plus=NIL;
XLVAL s_1star=NIL,s_2star=NIL,s_3star=NIL;
XLVAL s_minus=NIL,s_printcase=NIL;
X
X/* keywords */
XLVAL k_test=NIL,k_tnot=NIL;
XLVAL k_wspace=NIL,k_const=NIL,k_nmacro=NIL,k_tmacro=NIL;
XLVAL k_sescape=NIL,k_mescape=NIL;
XLVAL k_direction=NIL,k_input=NIL,k_output=NIL;
XLVAL k_start=NIL,k_end=NIL,k_1start=NIL,k_1end=NIL;
XLVAL k_2start=NIL,k_2end=NIL,k_count=NIL,k_key=NIL;
XLVAL k_verbose=NIL,k_print=NIL;
XLVAL k_upcase=NIL,k_downcase=NIL;
X
X/* lambda list keywords */
XLVAL lk_optional=NIL,lk_rest=NIL,lk_key=NIL,lk_aux=NIL;
XLVAL lk_allow_other_keys=NIL;
X
X/* type names */
XLVAL a_subr=NIL,a_fsubr=NIL;
XLVAL a_cons=NIL,a_symbol=NIL,a_fixnum=NIL,a_flonum=NIL;
XLVAL a_string=NIL,a_object=NIL,a_stream=NIL,a_vector=NIL;
XLVAL a_closure=NIL,a_char=NIL,a_ustream=NIL;
X
X/* evaluation variables */
XLVAL **xlstack = NULL,**xlstkbase = NULL,**xlstktop = NULL;
XLVAL xlenv=NIL,xlfenv=NIL,xldenv=NIL;
X
X/* argument stack */
XLVAL *xlargstkbase = NULL;    /* argument stack base */
XLVAL *xlargstktop = NULL;    /* argument stack top */
XLVAL *xlfp = NULL;        /* argument frame pointer */
XLVAL *xlsp = NULL;        /* argument stack pointer */
XLVAL *xlargv = NULL;        /* current argument vector */
Xint xlargc = 0;            /* current argument count */
X
X/* exception handling variables */
XCONTEXT *xlcontext = NULL;    /* current exception handler */
XCONTEXT *xltarget = NULL;    /* target context (for xljump) */
XLVAL xlvalue=NIL;        /* exception value (for xljump) */
Xint xlmask=0;            /* exception type (for xljump) */
X
X/* debugging variables */
Xint xldebug = 0;        /* debug level */
Xint xlsample = 0;        /* control character sample rate */
Xint xltrcindent = 0;        /* trace indent level */
X
X/* gensym variables */
Xchar gsprefix[STRMAX+1] = { 'G',0 };    /* gensym prefix string */
Xint gsnumber = 1;        /* gensym number */
X
X/* i/o variables */
Xint xlfsize = 0;        /* flat size of current print call */
XFILE *tfp = NULL;        /* transcript file pointer */
X
X/* general purpose string buffer */
Xchar buf[STRMAX+1] = { 0 };
X
X/* Include hybrid-class functions: *//* JSP */
X#define MODULE_XLGLOB_C_GLOBALS
X#include "../../xmodules.h"
X#undef MODULE_XLGLOB_C_GLOBALS
X
END_OF_FILE
if test 4866 -ne `wc -c <'src/xlisp/xcore/c/xlglob.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xlglob.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xlglob.c'
fi
if test -f 'src/xlisp/xcore/c/xlio.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlio.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xlio.c'\" \(6016 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xlio.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xlio.c
X* RCS:          $Header: xlio.c,v 1.2 89/11/25 05:33:04 mayer Exp $
X* Description:  xlisp i/o routines
X* Author:       David Michael Betz
X* Created:
X* Modified:     Sat Nov 25 05:32:45 1989 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
Xstatic char rcs_identity[] = "@(#)$Header: xlio.c,v 1.2 89/11/25 05:33:04 mayer Exp $";
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL s_stdin,s_stdout,s_stderr,s_debugio,s_traceout,s_unbound;
Xextern int xlfsize;
X
X/* xlgetc - get a character from a file or stream */
Xint xlgetc(fptr)
X  LVAL fptr;
X{
X    LVAL lptr,cptr;
X    FILE *fp;
X    int ch;
X
X    /* check for input from nil */
X    if (fptr == NIL)
X    ch = EOF;
X
X    /* otherwise, check for input from a stream */
X    else if (ustreamp(fptr)) {
X    if ((lptr = gethead(fptr)) == NIL)
X        ch = EOF;
X    else {
X        if (!consp(lptr) || (cptr = car(lptr)) == NIL || !charp(cptr))
X        xlfail("bad stream");
X        sethead(fptr,lptr = cdr(lptr));
X        if (lptr == NIL)
X        settail(fptr,NIL);
X        ch = getchcode(cptr);
X    }
X    }
X
X    /* otherwise, check for a buffered character */
X    else if (ch = getsavech(fptr))
X    setsavech(fptr,'\0');
X
X    /* otherwise, check for terminal input or file input */
X    else {
X    fp = getfile(fptr);
X    if (fp == stdin || fp == stderr)
X        ch = ostgetc();
X    else
X        ch = osagetc(fp);
X    }
X
X    /* return the character */
X    return (ch);
X}
X
X/* xlungetc - unget a character */
Xxlungetc(fptr,ch)
X  LVAL fptr; int ch;
X{
X    LVAL lptr;
X
X    /* check for ungetc from nil */
X    if (fptr == NIL)
X    ;
X
X    /* otherwise, check for ungetc to a stream */
X    if (ustreamp(fptr)) {
X    if (ch != EOF) {
X        lptr = cons(cvchar(ch),gethead(fptr));
X        if (gethead(fptr) == NIL)
X        settail(fptr,lptr);
X        sethead(fptr,lptr);
X    }
X    }
X
X    /* otherwise, it must be a file */
X    else
X    setsavech(fptr,ch);
X}
X
X/* xlpeek - peek at a character from a file or stream */
Xint xlpeek(fptr)
X  LVAL fptr;
X{
X    LVAL lptr,cptr;
X    int ch;
X
X    /* check for input from nil */
X    if (fptr == NIL)
X    ch = EOF;
X
X    /* otherwise, check for input from a stream */
X    else if (ustreamp(fptr)) {
X    if ((lptr = gethead(fptr)) == NIL)
X        ch = EOF;
X    else {
X        if (!consp(lptr) || (cptr = car(lptr)) == NIL || !charp(cptr))
X        xlfail("bad stream");
X        ch = getchcode(cptr);
X    }
X    }
X
X    /* otherwise, get the next file character and save it */
X    else {
X    ch = xlgetc(fptr);
X    setsavech(fptr,ch);
X    }
X
X    /* return the character */
X    return (ch);
X}
X
X/* xlputc - put a character to a file or stream */
Xxlputc(fptr,ch)
X  LVAL fptr; int ch;
X{
X    LVAL lptr;
X    FILE *fp;
X
X    /* count the character */
X    ++xlfsize;
X
X    /* check for output to nil */
X    if (fptr == NIL)
X    ;
X
X    /* otherwise, check for output to an unnamed stream */
X    else if (ustreamp(fptr)) {
X    lptr = consa(cvchar(ch));
X    if (gettail(fptr))
X        rplacd(gettail(fptr),lptr);
X    else
X        sethead(fptr,lptr);
X    settail(fptr,lptr);
X    }
X
X    /* otherwise, check for terminal output or file output */
X    else {
X    fp = getfile(fptr);
X    if (fp == stdout || fp == stderr)
X        ostputc(ch);
X    else
X        osaputc(ch,fp);
X    }
X}
X
X/* xlflush - flush the input buffer */
Xint xlflush()
X{
X    osflush();
X}
X
X/* stdprint - print to *standard-output* */
Xstdprint(expr)
X  LVAL expr;
X{
X    xlprint(getvalue(s_stdout),expr,TRUE);
X    xlterpri(getvalue(s_stdout));
X}
X
X/* stdputstr - print a string to *standard-output* */
Xstdputstr(str)
X  char *str;
X{
X    xlputstr(getvalue(s_stdout),str);
X}
X
X/* errprint - print to *error-output* */
Xerrprint(expr)
X  LVAL expr;
X{
X    xlprint(getvalue(s_stderr),expr,TRUE);
X    xlterpri(getvalue(s_stderr));
X}
X
X/* errputstr - print a string to *error-output* */
Xerrputstr(str)
X  char *str;
X{
X    xlputstr(getvalue(s_stderr),str);
X}
X
X/* dbgprint - print to *debug-io* */
Xdbgprint(expr)
X  LVAL expr;
X{
X    xlprint(getvalue(s_debugio),expr,TRUE);
X    xlterpri(getvalue(s_debugio));
X}
X
X/* dbgputstr - print a string to *debug-io* */
Xdbgputstr(str)
X  char *str;
X{
X    xlputstr(getvalue(s_debugio),str);
X}
X
X/* trcprin1 - print to *trace-output* */
Xtrcprin1(expr)
X  LVAL expr;
X{
X    xlprint(getvalue(s_traceout),expr,TRUE);
X}
X
X/* trcputstr - print a string to *trace-output* */
Xtrcputstr(str)
X  char *str;
X{
X    xlputstr(getvalue(s_traceout),str);
X}
X
X
END_OF_FILE
if test 6016 -ne `wc -c <'src/xlisp/xcore/c/xlio.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xlio.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xlio.c'
fi
if test -f 'src/xlisp/xcore/c/xljump.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xljump.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xljump.c'\" \(5855 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xljump.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xljump.c
X* RCS:          $Header: xljump.c,v 1.2 89/11/25 05:38:38 mayer Exp $
X* Description:  execution context routines
X* Author:       David Michael Betz
X* Created:
X* Modified:     Sat Nov 25 05:38:31 1989 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
Xstatic char rcs_identity[] = "@(#)$Header: xljump.c,v 1.2 89/11/25 05:38:38 mayer Exp $";
X
X
X#include "xlisp.h"
X
X/* external variables */
Xextern CONTEXT *xlcontext,*xltarget;
Xextern LVAL xlvalue,xlenv,xlfenv,xldenv;
Xextern int xlmask;
X
X/* xlbegin - beginning of an execution context */
Xxlbegin(cptr,flags,expr)
X  CONTEXT *cptr; int flags; LVAL expr;
X{
X    cptr->c_flags = flags;
X    cptr->c_expr = expr;
X    cptr->c_xlstack = xlstack;
X    cptr->c_xlenv = xlenv;
X    cptr->c_xlfenv = xlfenv;
X    cptr->c_xldenv = xldenv;
X    cptr->c_xlcontext = xlcontext;
X    cptr->c_xlargv = xlargv;
X    cptr->c_xlargc = xlargc;
X    cptr->c_xlfp = xlfp;
X    cptr->c_xlsp = xlsp;
X    xlcontext = cptr;
X}
X
X/* xlend - end of an execution context */
Xxlend(cptr)
X  CONTEXT *cptr;
X{
X    xlcontext = cptr->c_xlcontext;
X}
X
X/* xlgo - go to a label */
Xxlgo(label)
X  LVAL label;
X{
X    CONTEXT *cptr;
X    LVAL *argv;
X    int argc;
X
X    /* find a tagbody context */
X    for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X    if (cptr->c_flags & CF_GO) {
X        argc = cptr->c_xlargc;
X        argv = cptr->c_xlargv;
X        while (--argc >= 0)
X        if (*argv++ == label) {
X            cptr->c_xlargc = argc;
X            cptr->c_xlargv = argv;
X            xljump(cptr,CF_GO,NIL);
X        }
X    }
X    xlfail("no target for GO");
X}
X
X/* xlreturn - return from a block */
Xxlreturn(name,val)
X  LVAL name,val;
X{
X    CONTEXT *cptr;
X
X    /* find a block context */
X    for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X    if (cptr->c_flags & CF_RETURN && cptr->c_expr == name)
X        xljump(cptr,CF_RETURN,val);
X    xlfail("no target for RETURN");
X}
X
X/* xlthrow - throw to a catch */
Xxlthrow(tag,val)
X  LVAL tag,val;
X{
X    CONTEXT *cptr;
X
X    /* find a catch context */
X    for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X    if ((cptr->c_flags & CF_THROW) && cptr->c_expr == tag)
X        xljump(cptr,CF_THROW,val);
X    xlfail("no target for THROW");
X}
X
X/* xlsignal - signal an error */
Xxlsignal(emsg,arg)
X  char *emsg; LVAL arg;
X{
X    CONTEXT *cptr;
X
X    /* find an error catcher */
X    for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X    if (cptr->c_flags & CF_ERROR) {
X        if (cptr->c_expr && emsg)
X        xlerrprint("error",NULL,emsg,arg);
X        xljump(cptr,CF_ERROR,NIL);
X    }
X}
X
X/* xltoplevel - go back to the top level */
Xxltoplevel()
X{
X    stdputstr("[ back to top level ]\n");
X    findandjump(CF_TOPLEVEL,"no top level");
X}
X
X/* xlbrklevel - go back to the previous break level */
Xxlbrklevel()
X{
X    findandjump(CF_BRKLEVEL,"no previous break level");
X}
X
X/* xlcleanup - clean-up after an error */
Xxlcleanup()
X{
X    stdputstr("[ back to previous break level ]\n");
X    findandjump(CF_CLEANUP,"not in a break loop");
X}
X
X/* xlcontinue - continue from an error */
Xxlcontinue()
X{
X    findandjump(CF_CONTINUE,"not in a break loop");
X}
X
X/* xljump - jump to a saved execution context */
Xxljump(target,mask,val)
X  CONTEXT *target; int mask; LVAL val;
X{
X    /* unwind the execution stack */
X    for (; xlcontext != target; xlcontext = xlcontext->c_xlcontext)
X
X    /* check for an UNWIND-PROTECT */
X    if ((xlcontext->c_flags & CF_UNWIND)) {
X        xltarget = target;
X        xlmask = mask;
X        break;
X    }
X
X    /* restore the state */
X    xlstack = xlcontext->c_xlstack;
X    xlenv = xlcontext->c_xlenv;
X    xlfenv = xlcontext->c_xlfenv;
X    xlunbind(xlcontext->c_xldenv);
X    xlargv = xlcontext->c_xlargv;
X    xlargc = xlcontext->c_xlargc;
X    xlfp = xlcontext->c_xlfp;
X    xlsp = xlcontext->c_xlsp;
X    xlvalue = val;
X
X    /* call the handler */
X    xllongjmp(xlcontext->c_jmpbuf,mask);
X}
X
X/* findandjump - find a target context frame and jump to it */
XLOCAL findandjump(mask,error)
X  int mask; char *error;
X{
X    CONTEXT *cptr;
X
X    /* find a block context */
X    for (cptr = xlcontext; cptr; cptr = cptr->c_xlcontext)
X    if (cptr->c_flags & mask)
X        xljump(cptr,mask,NIL);
X    xlabort(error);
X}
X
END_OF_FILE
if test 5855 -ne `wc -c <'src/xlisp/xcore/c/xljump.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xljump.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xljump.c'
fi
if test -f 'src/xlisp/xcore/c/xlpp.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlpp.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xlpp.c'\" \(4222 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xlpp.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xlpp.c
X* RCS:          $Header: xlpp.c,v 1.2 89/11/25 05:42:08 mayer Exp $
X* Description:  xlisp pretty printer
X* Author:       David Michael Betz
X* Created:
X* Modified:     Sat Nov 25 05:42:00 1989 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
Xstatic char rcs_identity[] = "@(#)$Header: xlpp.c,v 1.2 89/11/25 05:42:08 mayer Exp $";
X
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL s_stdout, s_stderr;
Xextern int xlfsize;
X
X/* local variables */
Xstatic int pplevel,ppmargin,ppmaxlen;
Xstatic LVAL ppfile;
X
X/* xpp - pretty-print an expression */
XLVAL xpp()
X{
X    LVAL expr;
X
X    /* get expression to print and file pointer */
X    expr = xlgetarg();
X    ppfile = (moreargs() ? xlgetfile() : getvalue(s_stdout));
X    xllastarg();
X
X    /* pretty print the expression */
X    pplevel = ppmargin = 0; ppmaxlen = 40;
X    pp(expr); ppterpri(ppfile);
X
X    /* return nil */
X    return (NIL);
X}
X
X/* pp - pretty print an expression */
XLOCAL pp(expr)
X  LVAL expr;
X{
X    if (consp(expr))
X    pplist(expr);
X    else
X    ppexpr(expr);
X}
X
X/* pplist - pretty print a list */
XLOCAL pplist(expr)
X  LVAL expr;
X{
X    int n;
X
X    /* if the expression will fit on one line, print it on one */
X    if ((n = sexpflatsize(expr)) < ppmaxlen) {
X    xlprint(ppfile,expr,TRUE);
X    pplevel += n;
X    }
X
X    /* otherwise print it on several lines */
X    else {
X    n = ppmargin;
X    ppputc('(');
X    if (atom(car(expr))) {
X        ppexpr(car(expr));
X        ppputc(' ');
X        ppmargin = pplevel;
X        expr = cdr(expr);
X    }
X    else
X        ppmargin = pplevel;
X    for (; consp(expr); expr = cdr(expr)) {
X        pp(car(expr));
X        if (consp(cdr(expr)))
X        ppterpri();
X    }
X    if (expr != NIL) {
X        ppputc(' '); ppputc('.'); ppputc(' ');
X        ppexpr(expr);
X    }
X    ppputc(')');
X    ppmargin = n;
X    }
X}
X
X/* ppexpr - print an expression and update the indent level */
XLOCAL ppexpr(expr)
X  LVAL expr;
X{
X    xlprint(ppfile,expr,TRUE);
X    pplevel += sexpflatsize(expr);
X}
X
X/* ppputc - output a character and update the indent level */
XLOCAL ppputc(ch)
X  int ch;
X{
X    xlputc(ppfile,ch);
X    pplevel++;
X}
X
X/* ppterpri - terminate the print line and indent */
XLOCAL ppterpri()
X{
X    xlterpri(ppfile);
X    for (pplevel = 0; pplevel < ppmargin; pplevel++)
X    xlputc(ppfile,' ');
X}
X
X/* sexpflatsize - compute the flat size of an expression */
X/* name change from flatsize to sexpflatsize */ /* Voodoo */
XLOCAL int sexpflatsize(expr)
X  LVAL expr;
X{
X    xlfsize = 0;
X    xlprint(NIL,expr,TRUE);
X    return (xlfsize);
X}
END_OF_FILE
if test 4222 -ne `wc -c <'src/xlisp/xcore/c/xlpp.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xlpp.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xlpp.c'
fi
if test -f 'src/xlisp/xcore/c/xlsubr.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlsubr.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xlsubr.c'\" \(6250 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xlsubr.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xlsubr.c
X* RCS:          $Header: xlsubr.c,v 1.2 89/11/25 05:48:29 mayer Exp $
X* Description:  xlisp builtin function support routines
X* Author:       David Michael Betz
X* Created:
X* Modified:     Sat Nov 25 05:48:21 1989 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
Xstatic char rcs_identity[] = "@(#)$Header: xlsubr.c,v 1.2 89/11/25 05:48:29 mayer Exp $";
X
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL k_test,k_tnot,s_eql;
X
X/* xlsubr - define a builtin function */
XLVAL xlsubr(sname,type,fcn,offset)
X  char *sname; int type; LVAL (*fcn)(); int offset;
X{
X    LVAL sym;
X    sym = xlenter(sname);
X    setfunction(sym,cvsubr(fcn,type,offset));
X    return (sym);
X}
X
X/* xlgetkeyarg - get a keyword argument */
Xint xlgetkeyarg(key,pval)
X  LVAL key,*pval;
X{
X    LVAL *argv;
X    int argc;
X
X    for (argv = xlargv, argc = xlargc; (argc -= 2) >= 0; argv += 2) {
X    if (*argv == key) {
X        *pval = *++argv;
X        return (TRUE);
X    }
X    }
X    return (FALSE);
X}
X
X/* xlgkfixnum - get a fixnum keyword argument */
Xint xlgkfixnum(key,pval)
X  LVAL key,*pval;
X{
X    if (xlgetkeyarg(key,pval)) {
X    if (!fixp(*pval))
X        xlbadtype(*pval);
X    return (TRUE);
X    }
X    return (FALSE);
X}
X
X/* xltest - get the :test or :test-not keyword argument */
Xxltest(pfcn,ptresult)
X  LVAL *pfcn; int *ptresult;
X{
X    if (xlgetkeyarg(k_test,pfcn))    /* :test */
X    *ptresult = TRUE;
X    else if (xlgetkeyarg(k_tnot,pfcn))    /* :test-not */
X    *ptresult = FALSE;
X    else {
X    *pfcn = getfunction(s_eql);
X    *ptresult = TRUE;
X    }
X}
X
X/* xlgetfile - get a file or stream */
XLVAL xlgetfile()
X{
X    LVAL arg;
X
X    /* get a file or stream (cons) or nil */
X    if (arg = xlgetarg()) {
X    if (streamp(arg)) {
X        if (getfile(arg) == NULL)
X        xlfail("file not open");
X    }
X    else if (!ustreamp(arg))
X        xlerror("bad argument type",arg);
X    }
X    return (arg);
X}
X
X/* xlgetfname - get a filename */
XLVAL xlgetfname()
X{
X    LVAL name;
X
X    /* get the next argument */
X    name = xlgetarg();
X
X    /* get the filename string */
X    if (symbolp(name))
X    name = getpname(name);
X    else if (!stringp(name))
X    xlerror("bad argument type",name);
X
X    /* return the name */
X    return (name);
X}
X
X/* needsextension - check if a filename needs an extension */
Xint needsextension(name)
X  char *name;
X{
X    char *p;
X
X    /* check for an extension */
X    for (p = &name[strlen(name)]; --p >= &name[0]; )
X    if (*p == '.')
X        return (FALSE);
X    else if (!islower(*p) && !isupper(*p) && !isdigit(*p))
X        return (TRUE);
X
X    /* no extension found */
X    return (TRUE);
X}
X
X/* xlbadtype - report a "bad argument type" error */
XLVAL xlbadtype(arg)
X  LVAL arg;
X{
X    xlerror("bad argument type",arg);
X}
X
X/* xlbadinit - report a "bad initializer list" error */
XLVAL xlbadinit(arg)
X  LVAL arg;
X{
X    xlerror("bad initializer list",arg);
X}
X
X/* xltoofew - report a "too few arguments" error */
XLVAL xltoofew()
X{
X    xlfail("too few arguments");
X}
X
X/* xltoomany - report a "too many arguments" error */
Xxltoomany()
X{
X
X    xlfail("too many arguments");
X}
X
X/* eq - internal eq function */
Xint eq(arg1,arg2)
X  LVAL arg1,arg2;
X{
X    return (arg1 == arg2);
X}
X
X/* eql - internal eql function */
Xint eql(arg1,arg2)
X  LVAL arg1,arg2;
X{
X    /* compare the arguments */
X    if (arg1 == arg2)
X    return (TRUE);
X    else if (arg1) {
X    switch (ntype(arg1)) {
X    case FIXNUM:
X        return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
X    case FLONUM:
X        return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
X    default:
X        return (FALSE);
X    }
X    }
X    else
X    return (FALSE);
X}
X
X/* equal - internal equal function */
Xint equal(arg1,arg2)
X  LVAL arg1,arg2;
X{
X    /* compare the arguments */
X    if (arg1 == arg2)
X    return (TRUE);
X    else if (arg1) {
X    switch (ntype(arg1)) {
X    case FIXNUM:
X        return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
X    case FLONUM:
X        return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
X    case STRING:
X        return (stringp(arg2) ? strcmp(getstring(arg1),
X                       getstring(arg2)) == 0 : FALSE);
X    case CONS:
X        return (consp(arg2) ? equal(car(arg1),car(arg2))
X                   && equal(cdr(arg1),cdr(arg2)) : FALSE);
X/* awm */
X    case VECTOR:
X        if( vectorp( arg2) && (getsz( arg1) == getsz( arg2))) {
X          int i;
X          for( i = 0; i < getsz( arg1); i++) {
X        if( !equal( getelement( arg1, i), getelement( arg2, i)))
X          return FALSE;
X          }
X          return TRUE;
X        }
X        else {
X          return FALSE;
X        }
X/* awm */
X    default:
X        return (FALSE);
X    }
X    }
X    else
X    return (FALSE);
X}
END_OF_FILE
if test 6250 -ne `wc -c <'src/xlisp/xcore/c/xlsubr.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xlsubr.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xlsubr.c'
fi
if test -f 'src/xlisp/xcore/c/xlsym.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlsym.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xlsym.c'\" \(7019 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xlsym.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xlsym.c
X* RCS:          $Header: xlsym.c,v 1.2 89/11/25 05:49:24 mayer Exp $
X* Description:  symbol handling routines
X* Author:       David Michael Betz
X* Created:
X* Modified:     Sat Nov 25 05:49:18 1989 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
Xstatic char rcs_identity[] = "@(#)$Header: xlsym.c,v 1.2 89/11/25 05:49:24 mayer Exp $";
X
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL obarray,s_unbound;
Xextern LVAL xlenv,xlfenv,xldenv;
X
X/* forward declarations */
XFORWARD LVAL findprop();
X
X/* xlenter - enter a symbol into the obarray */
XLVAL xlenter(name)
X  char *name;
X{
X    LVAL sym,array;
X    int i;
X
X    /* check for nil */
X    if (strcmp(name,"NIL") == 0)
X    return (NIL);
X
X    /* check for symbol already in table */
X    array = getvalue(obarray);
X    i = hash(name,HSIZE);
X    for (sym = getelement(array,i); sym; sym = cdr(sym))
X    if (strcmp(name,getstring(getpname(car(sym)))) == 0)
X        return (car(sym));
X
X    /* make a new symbol node and link it into the list */
X    xlsave1(sym);
X    sym = consd(getelement(array,i));
X    rplaca(sym,xlmakesym(name));
X    setelement(array,i,sym);
X    xlpop();
X
X    /* return the new symbol */
X    return (car(sym));
X}
X
X/* xlmakesym - make a new symbol node */
XLVAL xlmakesym(name)
X  char *name;
X{
X    LVAL sym;
X    sym = cvsymbol(name);
X    if (*name == ':')
X    setvalue(sym,sym);
X    return (sym);
X}
X
X/* xlgetvalue - get the value of a symbol (with check) */
XLVAL xlgetvalue(sym)
X  LVAL sym;
X{
X    LVAL val;
X
X    /* look for the value of the symbol */
X    while ((val = xlxgetvalue(sym)) == s_unbound)
X    xlunbound(sym);
X
X    /* return the value */
X    return (val);
X}
X
X/* xlxgetvalue - get the value of a symbol */
XLVAL xlxgetvalue(sym)
X  LVAL sym;
X{
X    register LVAL fp,ep;
X    LVAL val;
X
X    /* check the environment list */
X    for (fp = xlenv; fp; fp = cdr(fp))
X
X    /* check for an instance variable */
X    if ((ep = car(fp)) && objectp(car(ep))) {
X        if (xlobgetvalue(ep,sym,&val))
X        return (val);
X    }
X
X    /* check an environment stack frame */
X    else {
X        for (; ep; ep = cdr(ep))
X        if (sym == car(car(ep)))
X            return (cdr(car(ep)));
X    }
X
X    /* return the global value */
X    return (getvalue(sym));
X}
X
X/* xlsetvalue - set the value of a symbol */
Xxlsetvalue(sym,val)
X  LVAL sym,val;
X{
X    register LVAL fp,ep;
X
X    /* look for the symbol in the environment list */
X    for (fp = xlenv; fp; fp = cdr(fp))
X
X    /* check for an instance variable */
X    if ((ep = car(fp)) && objectp(car(ep))) {
X        if (xlobsetvalue(ep,sym,val))
X        return;
X    }
X
X    /* check an environment stack frame */
X    else {
X        for (; ep; ep = cdr(ep))
X        if (sym == car(car(ep))) {
X            rplacd(car(ep),val);
X            return;
X        }
X    }
X
X    /* store the global value */
X    setvalue(sym,val);
X}
X
X/* xlgetfunction - get the functional value of a symbol (with check) */
XLVAL xlgetfunction(sym)
X  LVAL sym;
X{
X    LVAL val;
X
X    /* look for the functional value of the symbol */
X    while ((val = xlxgetfunction(sym)) == s_unbound)
X    xlfunbound(sym);
X
X    /* return the value */
X    return (val);
X}
X
X/* xlxgetfunction - get the functional value of a symbol */
XLVAL xlxgetfunction(sym)
X  LVAL sym;
X{
X    register LVAL fp,ep;
X
X    /* check the environment list */
X    for (fp = xlfenv; fp; fp = cdr(fp))
X    for (ep = car(fp); ep; ep = cdr(ep))
X        if (sym == car(car(ep)))
X        return (cdr(car(ep)));
X
X    /* return the global value */
X    return (getfunction(sym));
X}
X
X/* xlsetfunction - set the functional value of a symbol */
Xxlsetfunction(sym,val)
X  LVAL sym,val;
X{
X    register LVAL fp,ep;
X
X    /* look for the symbol in the environment list */
X    for (fp = xlfenv; fp; fp = cdr(fp))
X    for (ep = car(fp); ep; ep = cdr(ep))
X        if (sym == car(car(ep))) {
X        rplacd(car(ep),val);
X        return;
X        }
X
X    /* store the global value */
X    setfunction(sym,val);
X}
X
X/* xlgetprop - get the value of a property */
XLVAL xlgetprop(sym,prp)
X  LVAL sym,prp;
X{
X    LVAL p;
X    return ((p = findprop(sym,prp)) ? car(p) : NIL);
X}
X
X/* xlputprop - put a property value onto the property list */
Xxlputprop(sym,val,prp)
X  LVAL sym,val,prp;
X{
X    LVAL pair;
X    if (pair = findprop(sym,prp))
X    rplaca(pair,val);
X    else
X    setplist(sym,cons(prp,cons(val,getplist(sym))));
X}
X
X/* xlremprop - remove a property from a property list */
Xxlremprop(sym,prp)
X  LVAL sym,prp;
X{
X    LVAL last,p;
X    last = NIL;
X    for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(last)) {
X    if (car(p) == prp)
X        if (last)
X        rplacd(last,cdr(cdr(p)));
X        else
X        setplist(sym,cdr(cdr(p)));
X    last = cdr(p);
X    }
X}
X
X/* findprop - find a property pair */
XLOCAL LVAL findprop(sym,prp)
X  LVAL sym,prp;
X{
X    LVAL p;
X    for (p = getplist(sym); consp(p) && consp(cdr(p)); p = cdr(cdr(p)))
X    if (car(p) == prp)
X        return (cdr(p));
X    return (NIL);
X}
X
X/* hash - hash a symbol name string */
Xint hash(str,len)
X  char *str;
X{
X    int i;
X    for (i = 0; *str; )
X    i = (i << 2) ^ *str++;
X    i %= len;
X    return (i < 0 ? -i : i);
X}
X
X/* xlsinit - symbol initialization routine */
Xxlsinit()
X{
X    LVAL array,p;
X
X    /* initialize the obarray */
X    obarray = xlmakesym("*OBARRAY*");
X    array = newvector(HSIZE);
X    setvalue(obarray,array);
X
X    /* add the symbol *OBARRAY* to the obarray */
X    p = consa(obarray);
X    setelement(array,hash("*OBARRAY*",HSIZE),p);
X}
END_OF_FILE
if test 7019 -ne `wc -c <'src/xlisp/xcore/c/xlsym.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xlsym.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xlsym.c'
fi
if test -f 'src/xlisp/xcore/c/xlsys.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlsys.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xlsys.c'\" \(5566 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xlsys.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xlsys.c
X* RCS:          $Header: xlsys.c,v 1.5 89/11/25 05:49:55 mayer Exp $
X* Description:  xlisp builtin system functions
X* Author:       David Michael Betz
X* Created:
X* Modified:     Sat Nov 25 05:49:49 1989 (Niels Mayer) mayer@hplnpm
X* Language:     C
X* Package:      N/A
X* Status:       X11r4 contrib tape release
X*
X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer).
X* XLISP version 2.1, Copyright (c) 1989, by David Betz.
X*
X* Permission to use, copy, modify, distribute, and sell this software and its
X* documentation for any purpose is hereby granted without fee, provided that
X* the above copyright notice appear in all copies and that both that
X* copyright notice and this permission notice appear in supporting
X* documentation, and that the name of Hewlett-Packard and David Betz not be
X* used in advertising or publicity pertaining to distribution of the software
X* without specific, written prior permission.  Hewlett-Packard and David Betz
X* make no representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* See ./winterp/COPYRIGHT for information on contacting the authors.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
Xstatic char rcs_identity[] = "@(#)$Header: xlsys.c,v 1.5 89/11/25 05:49:55 mayer Exp $";
X
X
X#include "xlisp.h"
X
X/* external variables */
Xextern jmp_buf top_level;
Xextern FILE *tfp;
X
X/* external symbols */
Xextern LVAL a_subr,a_fsubr,a_cons,a_symbol;
Xextern LVAL a_fixnum,a_flonum,a_string,a_object,a_stream;
Xextern LVAL a_vector,a_closure,a_char,a_ustream;
Xextern LVAL k_verbose,k_print;
Xextern LVAL true;
X
X
X/* external routines */
Xextern FILE *osaopen();
X
X/* Include hybrid-class functions: *//* JSP */
X#define MODULE_XLSYS_C_GLOBALS
X#include "../../xmodules.h"
X#undef MODULE_XLSYS_C_GLOBALS
X
X
X/* xload - read and evaluate expressions from a file */
XLVAL xload()
X{
X    unsigned char *name;
X    int vflag,pflag;
X    LVAL arg;
X
X    /* get the file name */
X    name = getstring(xlgetfname());
X
X    /* get the :verbose flag */
X    if (xlgetkeyarg(k_verbose,&arg))
X    vflag = (arg != NIL);
X    else
X    vflag = TRUE;
X
X    /* get the :print flag */
X    if (xlgetkeyarg(k_print,&arg))
X    pflag = (arg != NIL);
X    else
X    pflag = FALSE;
X
X    /* load the file */
X    return (xlload(name,vflag,pflag) ? true : NIL);
X}
X
X/* xtranscript - open or close a transcript file */
XLVAL xtranscript()
X{
X    unsigned char *name;
X
X    /* get the transcript file name */
X    name = (moreargs() ? getstring(xlgetfname()) : NULL);
X    xllastarg();
X
X    /* close the current transcript */
X    if (tfp) osclose(tfp);
X
X    /* open the new transcript */
X    tfp = (name ? osaopen(name,"w") : NULL);
X
X    /* return T if a transcript is open, NIL otherwise */
X    return (tfp ? true : NIL);
X}
X
X/* xtype - return type of a thing */
XLVAL xtype()
X{
X    LVAL arg;
X
X    if (!(arg = xlgetarg()))
X    return (NIL);
X
X    switch (ntype(arg)) {
X    case SUBR:        return (a_subr);
X    case FSUBR:        return (a_fsubr);
X    case CONS:        return (a_cons);
X    case SYMBOL:    return (a_symbol);
X    case FIXNUM:    return (a_fixnum);
X    case FLONUM:    return (a_flonum);
X    case STRING:    return (a_string);
X    case OBJECT:    return (a_object);
X    case STREAM:    return (a_stream);
X    case VECTOR:    return (a_vector);
X    case CLOSURE:    return (a_closure);
X    case CHAR:        return (a_char);
X    case USTREAM:    return (a_ustream);
X    case STRUCT:    return (getelement(arg,0));
X/* Include hybrid-class functions: *//* JSP */
X#define MODULE_XLSYS_C_XTYPE
X#include "../../xmodules.h"
X#undef MODULE_XLSYS_C_XTYPE
X    default:        xlfail("bad node type");
X    }
X}
X
X/* xbaktrace - print the trace back stack */
XLVAL xbaktrace()
X{
X    LVAL num;
X    int n;
X
X    if (moreargs()) {
X    num = xlgafixnum();
X    n = getfixnum(num);
X    }
X    else
X    n = -1;
X    xllastarg();
X    xlbaktrace(n);
X    return (NIL);
X}
X
X/* xexit - get out of xlisp */
XLVAL xexit()
X{
X    xllastarg();
X    wrapup();
X}
X
X/* xpeek - peek at a location in memory */
XLVAL xpeek()
X{
X    LVAL num;
X    int *adr;
X
X    /* get the address */
X    num = xlgafixnum(); adr = (int *)getfixnum(num);
X    xllastarg();
X
X    /* return the value at that address */
X    return (cvfixnum((FIXTYPE)*adr));
X}
X
X/* xpoke - poke a value into memory */
XLVAL xpoke()
X{
X    LVAL val;
X    int *adr;
X
X    /* get the address and the new value */
X    val = xlgafixnum(); adr = (int *)getfixnum(val);
X    val = xlgafixnum();
X    xllastarg();
X
X    /* store the new value */
X    *adr = (int)getfixnum(val);
X
X    /* return the new value */
X    return (val);
X}
X
X/* xaddrs - get the address of an XLISP node */
XLVAL xaddrs()
X{
X    LVAL val;
X
X    /* get the node */
X    val = xlgetarg();
X    xllastarg();
X
X    /* return the address of the node */
X    return (cvfixnum((FIXTYPE)val));
X}
X
END_OF_FILE
if test 5566 -ne `wc -c <'src/xlisp/xcore/c/xlsys.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xlsys.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xlsys.c'
fi
if test -f 'src/xlisp/xcore/c/xmain.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xmain.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xmain.c'\" \(3942 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xmain.c' <<'END_OF_FILE'
X/* xlisp.c - a small implementation of lisp with object-oriented programming */
X/*    Copyright (c) 1987, by David Michael Betz */
X
X#include "xlisp.h"
X
X/* define the banner line string */
X#define BANNER    "XLISP version 2.1, Copyright (c) 1989, by David Betz"
X
X/* global variables */
Xjmp_buf top_level;
X
X/* external variables */
Xextern LVAL s_stdin,s_evalhook,s_applyhook;
Xextern LVAL s_1plus,s_2plus,s_3plus,s_1star,s_2star,s_3star,s_minus;
Xextern int xltrcindent;
Xextern int xldebug;
Xextern LVAL true;
Xextern char buf[];
Xextern FILE *tfp;
X
X/* external routines */
Xextern FILE *osaopen();
Xextern void xlshutdown_hybrid();  /* Voodoo */
X
X/* xmain - the main routine */
Xxmain(argc,argv)
X  int argc; char *argv[];
X{
X    char *transcript;
X    CONTEXT cntxt;
X    int verbose,i;
X    LVAL expr;
X
X    /* setup default argument values */
X    transcript = NULL;
X    verbose = FALSE;
X
X    /* parse the argument list switches */
X#ifndef LSC
X    for (i = 1; i < argc; ++i) {
X    if (argv[i][0] == '-') {
X        switch(argv[i][1]) {
X        case 't':
X        case 'T':
X        transcript = &argv[i][2];
X        break;
X        case 'v':
X        case 'V':
X        verbose = TRUE;
X        break;
X        }
X        }
X    }
X#endif
X
X    /* initialize and print the banner line */
X    osinit(BANNER);
X
X    /* setup initialization error handler */
X    xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,(LVAL)1);
X    if (xlsetjmp(cntxt.c_jmpbuf))
X    xlfatal("fatal initialization error");
X    if (xlsetjmp(top_level))
X    xlfatal("RESTORE not allowed during initialization");
X
X    /* initialize xlisp */
X    xlinit();
X    xlend(&cntxt);
X
X    /* reset the error handler */
X    xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,true);
X
X    /* open the transcript file */
X    if (transcript && (tfp = osaopen(transcript,"w")) == NULL) {
X    sprintf(buf,"error: can't open transcript file: %s",transcript);
X    stdputstr(buf);
X    }
X
X    /* load "init.lsp" */
X    if (xlsetjmp(cntxt.c_jmpbuf) == 0)
X    xlload("init.lsp",TRUE,FALSE);
X
X    /* load any files mentioned on the command line */
X    if (xlsetjmp(cntxt.c_jmpbuf) == 0)
X    for (i = 1; i < argc; i++)
X        if (argv[i][0] != '-' && !xlload(argv[i],TRUE,verbose))
X        xlerror("can't load file",cvstring(argv[i]));
X
X    /* target for restore */
X    if (xlsetjmp(top_level))
X    xlbegin(&cntxt,CF_TOPLEVEL|CF_CLEANUP|CF_BRKLEVEL,true);
X
X    /* protect some pointers */
X    xlsave1(expr);
X
X    /* main command processing loop */
X    for (;;) {
X
X    /* setup the error return */
X    if (xlsetjmp(cntxt.c_jmpbuf)) {
X        setvalue(s_evalhook,NIL);
X        setvalue(s_applyhook,NIL);
X        xltrcindent = 0;
X        xldebug = 0;
X        xlflush();
X    }
X
X    /* print a prompt */
X    stdputstr("> ");
X
X    /* read an expression */
X    if (!xlread(getvalue(s_stdin),&expr,FALSE))
X        break;
X
X    /* save the input expression */
X    xlrdsave(expr);
X
X    /* evaluate the expression */
X    expr = xleval(expr);
X
X    /* save the result */
X    xlevsave(expr);
X
X    /* print it */
X    stdprint(expr);
X    }
X    xlend(&cntxt);
X
X    /* clean up */
X    wrapup();
X}
X
X/* xlrdsave - save the last expression returned by the reader */
Xxlrdsave(expr)
X  LVAL expr;
X{
X    setvalue(s_3plus,getvalue(s_2plus));
X    setvalue(s_2plus,getvalue(s_1plus));
X    setvalue(s_1plus,getvalue(s_minus));
X    setvalue(s_minus,expr);
X}
X
X/* xlevsave - save the last expression returned by the evaluator */
Xxlevsave(expr)
X  LVAL expr;
X{
X    setvalue(s_3star,getvalue(s_2star));
X    setvalue(s_2star,getvalue(s_1star));
X    setvalue(s_1star,expr);
X}
X
X/* xlfatal - print a fatal error message and exit */
X#ifndef BOGUS
Xxlfatal(msg)
X  char *msg;
X{
X    xoserror(msg);
X    wrapup();
X}
X#else
Xstatic xlfatal_zero = 0;
Xxlfatal(msg)
X  char *msg;
X{
X    xoserror(msg);
Xprintf( "\ndummy printf %x, %x", 1 / xlfatal_zero, *(int*)xlfatal_zero );
X    wrapup();
X}
X#endif
X
X
X/* wrapup - clean up and exit to the operating system */
Xwrapup()
X{
X    /* pass last ditch control to user packages */ /* Voodoo */
X    xlshutdown_hybrid();
X
X    if (tfp)   osclose(tfp);
X
X    osfinish();
X    exit(0);
X}
X
X
END_OF_FILE
if test 3942 -ne `wc -c <'src/xlisp/xcore/c/xmain.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xmain.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xmain.c'
fi
if test -f 'src/xlisp/xmodules.h' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xmodules.h'\"
else
echo shar: Extracting \"'src/xlisp/xmodules.h'\" \(3358 characters\)
sed "s/^X//" >'src/xlisp/xmodules.h' <<'END_OF_FILE'
X/* -*-C-*-                                                                   CrT
X********************************************************************************
X*
X* File:         xmodules.h
X* Description:  Master #include file for xlisp extension modules.
X* Author:       Jeff Prothero
X* Created:      90Nov16
X* Modified:
X* Language:     C
X* Package:      N/A
X* Status:
X*
X* Copyright (c) 1991, University of Washington (by Jeff Prothero)
X*
X* Permission to use, copy, modify, distribute, and sell this software
X* and its documentation for any purpose is hereby granted without fee,
X* provided that the above copyright notice appear in all copies and that
X* both that copyright notice and this permission notice appear in
X* supporting documentation, and that the name of University of
X* Washington and Jeff Prothero not be used in advertising or
X* publicity pertaining to distribution of the software without specific,
X* written prior permission.  University of Washington and Jeff Prothero make no
X* representations about the suitability of this software for any
X* purpose. It is provided "as is" without express or implied warranty.
X*
X* UNIVERITY OF WASHINGTON AND JEFF PROTHERO DISCLAIM ALL WARRANTIES WITH
X* REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
X* MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL UNIVERSITY OF WASHINGTON
X* NOR JEFF PROTHERO BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL
X* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
X* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
X* TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
X* PERFORMANCE OF THIS SOFTWARE.
X*
X* Please send modifications, improvements and bugfixes to [e-mail]
X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
X*
X********************************************************************************
X*/
X
X/**************************************************************************/
X/* Some xlisp functions are written in C.  We call them "primitive        */
X/* functions" because they look atomic to xlisp code.              */
X/*                                       */
X/* Some xlisp classes need C language support.  We call them "hybrid      */
X/* classes", since they are written partly in xlisp and partly in C.      */
X/* Sometimes the C part accesses special host facilities like graphics      */
X/* hardware, and sometimes it simply speeds up critical operations.      */
X/*                                       */
X/* This file provides a central, single point of connection between the   */
X/* xlisp interpreter code and the code for xlisp extension modules --     */
X/* hybrid classes and optional libraries of primitive functions.  Rather  */
X/* than scattering "#ifdef"s all through the xlisp interpreter, you should*/
X/* simply add a single '#include "myclass/c/xmyclass.h"' line to this     */
X/* file.  See the file "xcore/doc/mymodule.h" to find out what you should */
X/* put in "xmyclass.h".                              */
X/**************************************************************************/
X
X/* Order is important! */
X/*#include "winterp/c/xwinterp.h"/* Just a skeleton at the moment. */
X
X#ifdef banana
X#include   "gobject/c/xgbj.h"    /* General objects.           */
X#include   "3d/c/x3d.h"          /* Some 3-D graphics stuff.       */
X#include "gplotlib/c/xgplot.h" /* gplotlib + interface.          */
X#endif
END_OF_FILE
if test 3358 -ne `wc -c <'src/xlisp/xmodules.h'`; then
    echo shar: \"'src/xlisp/xmodules.h'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xmodules.h'
fi
echo shar: End of archive 2 \(of 16\).
cp /dev/null ark2isdone
MISSING=""
for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 16 archives.
    rm -f ark[1-9]isdone ark[1-9][0-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0