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

Text File | 1993-04-25 | 83.8 KB | 3,648 lines

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

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

#! /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 9 (of 16)."
# Contents:  src/utils/xform_prims.c src/xlisp/xcore/c/xlbfun.c
#   src/xlisp/xcore/c/xllist.c src/xlisp/xcore/c/xlread.c
# Wrapped by [e-mail] on Sun Apr 25 23:10:41 1993
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'src/utils/xform_prims.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/utils/xform_prims.c'\"
else
echo shar: Extracting \"'src/utils/xform_prims.c'\" \(19222 characters\)
sed "s/^X//" >'src/utils/xform_prims.c' <<'END_OF_FILE'
X/* xform_prims.c
X
X   by dav lion, at the HITLab, Seattle
X
X   Copyright (C) 1992  Human Interface Technology Lab, Seattle
X
X   xlisp wrappers for C based matrix geometrical transformation routines
X
X   this code is part of VEOS.
X*/
X
X
X/* xform10_MakeQuaternion() and
X   xform11_NormalizeQuaternion()
X   by Andrew MacDonald,
X   9 Mar 1992
X
X   xform04_PosQuat2Mat and xform08_multQuats() fixed to normalize correctly
X   9 Mar 1992
X
X   xform12_PointTimesQuat()
X   8 Apr 1992
X*/
X
X/****************************************************************************/
X/*                          preliminaries                   */
X
X#include <stdio.h>
X#include <math.h>
X#include <world.h>
X#include "xform_prims.h"
X/* . . . . . . . . . . . . . . F O R W A R D S . . . . . . . . . . . .  */
XLVAL xform01_identmatrix();
XLVAL xform02_multmatrix();
XLVAL xform03_translateMat();
XLVAL xform04_PosQuat2Mat();
XLVAL xform05_scaleMat();
XLVAL xform06_shearMat();
XLVAL xform07_copyMat();
XLVAL xform08_multQuats();
XLVAL xform09_Mat2PosQuat();
XLVAL xform10_MakeQuaternion();
XLVAL xform11_NormalizeQuaternion();
XLVAL xform12_PointTimesQuat();
X
Xvoid Xform_LoadPrims();
X
X
X
X
X/* . . . . . .. .... . . . . . G L O B A L S . . . . . . . . . . . . . .*/
X
X
X
X/* . . . . . . . . . . . . . . E X T E R N S  . . . .  . . . . . . . . .*/
X
X
Xextern LVAL    true;
Xextern int matrixp();
X
X/* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .*/
X
X/* . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .*/
X
X
Xvoid
XXform_LoadPrims()
X{
X
X    xldefine_prim("IDENTITYMATRIX",     SUBR, xform01_identMat);
X    xldefine_prim("MULTMATRIX",     SUBR, xform02_multMat);
X    xldefine_prim("TRANSLATEMATRIX",     SUBR, xform03_translateMat);
X    xldefine_prim("POSQUAT2MAT",     SUBR, xform04_PosQuat2Mat);
X    xldefine_prim("SCALEMATRIX",     SUBR, xform05_scaleMat);
X    xldefine_prim("SHEARMATRIX",     SUBR, xform06_shearMat);
X    xldefine_prim("COPYMATRIX",     SUBR, xform07_copyMat);
X    xldefine_prim("MULTQUATS",        SUBR, xform08_multQuats);
X    xldefine_prim("MAT2POSQUAT",    SUBR, xform09_Mat2PosQuat);
X    xldefine_prim("MAKEQUAT",        SUBR, xform10_MakeQuaternion);
X    xldefine_prim("NORMQUAT",        SUBR, xform11_NormalizeQuaternion);
X    xldefine_prim("POINTXQUAT",        SUBR, xform12_PointTimesQuat);
X
X    }/*XForm_LoadPrims*/
X
X
X
X
X
Xvoid
Xxform_normalizeVec(target, pMagnitude)
Xfloat    target[3];
Xfloat    *pMagnitude;
X{
X    float    magnitude;
X
X#ifdef SGI
X    magnitude = fsqrt(target[0] * target[0] +
X              target[1] * target[1] +
X              target[2] * target[2] );
X#else
X    magnitude = (float)sqrt((double)(target[0] * target[0] +
X                target[1] * target[1] +
X                target[2] * target[2] ));
X#endif
X
X
X    if (magnitude > EPSILON) {
X
X    target[0] /= magnitude;
X    target[1] /= magnitude;
X    target[2] /= magnitude;
X    }/*endif sane */
X    else
X    magnitude = 0.0;
X
X    *pMagnitude = magnitude;
X    }/*vecNormalizeVec*/
X
X
Xfloat
Xxform_magnitude( v)
X    Vector    v;
X{
X    return( sqrt( v[0] * v[0] + v[1] * v[1] + v[2] * v[2]));
X}
X
X
XLVAL
Xxform01_identMat()
X{
X    LVAL    lMat;
X    int        iCounter;
X
X    lMat = xlgetarg();
X
X    if (matrixp(lMat)) {
X    xllastarg();
X
X    stuff_flonum(lMat, 0, 1.0);
X    stuff_flonum(lMat, 1, 0.0);
X    stuff_flonum(lMat, 2, 0.0);
X    stuff_flonum(lMat, 3, 0.0);
X
X    stuff_flonum(lMat, 4, 0.0);
X    stuff_flonum(lMat, 5, 1.0);
X    stuff_flonum(lMat, 6, 0.0);
X    stuff_flonum(lMat, 7, 0.0);
X
X    stuff_flonum(lMat, 8, 0.0);
X    stuff_flonum(lMat, 9, 0.0);
X    stuff_flonum(lMat, 10, 1.0);
X    stuff_flonum(lMat, 11, 0.0);
X
X    stuff_flonum(lMat, 12, 0.0);
X    stuff_flonum(lMat, 13, 0.0);
X    stuff_flonum(lMat, 14, 0.0);
X    stuff_flonum(lMat, 15, 1.0);
X
X    }/*endif happy */
X    else
X    xlerror("Not a Matrix");
X
X    return (true);
X
X    }/*xform01_identMat*/
X
X
X
X
XLVAL
Xxform02_multMat()
X{
X    LVAL    lM1;
X    LVAL    lM2;
X    LVAL    lM3;
X
X    static    Matrix    temp;
X
X    int        y;
X    int        x;
X
X    lM1 = xlgetarg();
X    if (matrixp(lM1)) {
X
X    lM2 = xlgetarg();
X    if (matrixp(lM2)) {
X        lM3 = xlgetarg();
X        if (matrixp(lM3)) {
X        xllastarg();
X
X        for(y=0; y<4 ; y++)
X            for(x=0 ; x<4 ; x++) {
X            temp[y][x] = ( m_float(lM2, y, 0) * m_float(lM1, 0, x)
X                      + m_float(lM2, y, 1) * m_float(lM1, 1, x)
X                      + m_float(lM2, y, 2) * m_float(lM1, 2, x)
X                      + m_float(lM2, y, 3) * m_float(lM1, 3, x));
X            }/*for x*/
X
X        Mat2LispMat(temp,lM3);
X
X        }/*endif happy*/
X        else
X        xlerror("arg 3 not a matrix");
X        }/*endif arg2 a matrix*/
X    else
X        xlerror("arg2 not a matrix");
X    }/*endif arg1 a matrix*/
X    else
X    xlerror("arg 1 not a matrix");
X
X    return (true);
X
X    }/*xform02_multMat*/
X
X
X
XLVAL
Xxform03_translateMat()
X{
X    LVAL    lMat;
X    LVAL    lTri;
X
X    lMat = xlgetarg();
X    if (matrixp(lMat)) {
X    lTri = xlgetarg();
X    if (triplep(lTri)) {
X        xllastarg();
X
X        stuff_flonum(lMat, 0, 1.0);
X        stuff_flonum(lMat, 1, 0.0);
X        stuff_flonum(lMat, 2, 0.0);
X        stuff_flonum(lMat, 3, 0.0);
X
X        stuff_flonum(lMat, 4, 0.0);
X        stuff_flonum(lMat, 5, 1.0);
X        stuff_flonum(lMat, 6, 0.0);
X        stuff_flonum(lMat, 7, 0.0);
X
X        stuff_flonum(lMat, 8, 0.0);
X        stuff_flonum(lMat, 9, 0.0);
X        stuff_flonum(lMat, 10, 1.0);
X        stuff_flonum(lMat, 11, 0.0);
X
X        stuff_flonum(lMat, 12, v_float(lTri, 0));
X        stuff_flonum(lMat, 13, v_float(lTri, 1));
X        stuff_flonum(lMat, 14, v_float(lTri, 2));
X        stuff_flonum(lMat, 15, 1.0);
X
X        }/*endif happy*/
X    else
X        xlerror("arg 2 not a triple ");
X    }/*endif found matrix */
X    else
X    xlerror("arg 1 not a matrix");
X
X    return (true);
X
X    }/*xform03_translateMat*/
X
X
X
X
XLVAL
Xxform05_scaleMat()
X{
X    LVAL    lMat;
X    LVAL    lTri;
X
X    lMat = xlgetarg();
X    if (matrixp(lMat)) {
X
X    lTri = xlgetarg();
X    if (triplep(lTri)) {
X        xllastarg();
X
X        stuff_flonum(lMat, 0, v_float(lTri,0));
X        stuff_flonum(lMat, 1, 0.0);
X        stuff_flonum(lMat, 2, 0.0);
X        stuff_flonum(lMat, 3, 0.0);
X
X        stuff_flonum(lMat, 4, 1.0);
X        stuff_flonum(lMat, 5, v_float(lTri,1));
X        stuff_flonum(lMat, 6, 0.0);
X        stuff_flonum(lMat, 7, 0.0);
X
X        stuff_flonum(lMat, 8, 1.0);
X        stuff_flonum(lMat, 9, 0.0);
X        stuff_flonum(lMat, 10, v_float(lTri,2));
X        stuff_flonum(lMat, 11, 0.0);
X
X        stuff_flonum(lMat, 12, 0.0);
X        stuff_flonum(lMat, 13, 0.0);
X        stuff_flonum(lMat, 14, 0.0);
X        stuff_flonum(lMat, 15, 1.0);
X
X        }/*endif happy*/
X    else
X        xlerror("arg 2 not a triple");
X    }/*endif found matrix*/
X    else
X    xlerror("arg 1 not a matrix");
X
X    return (true);
X    }/*xform05_scaleMat*/
X
X
XLVAL
Xxform06_shearMat()
X{
X    LVAL    lMat;
X    LVAL    lX;
X    LVAL    lY;
X
X    lMat = xlgetarg();
X    if (matrixp(lMat)) {
X
X    lX = xlgaflonum();
X    lY = xlgaflonum();
X    xllastarg();
X
X    stuff_flonum(lMat, 0, 1.0);
X    stuff_flonum(lMat, 1, 0.0);
X    stuff_flonum(lMat, 2, 0.0);
X    stuff_flonum(lMat, 3, 0.0);
X
X    stuff_flonum(lMat, 4, getflonum(lX));
X    stuff_flonum(lMat, 5, getflonum(lY));
X    stuff_flonum(lMat, 6, 0.0);
X    stuff_flonum(lMat, 7, 0.0);
X
X    stuff_flonum(lMat, 8, 0.0);
X    stuff_flonum(lMat, 9, 0.0);
X    stuff_flonum(lMat, 10, 1.0);
X    stuff_flonum(lMat, 11, 0.0);
X
X    stuff_flonum(lMat, 12, 0.0);
X    stuff_flonum(lMat, 13, 0.0);
X    stuff_flonum(lMat, 14, 0.0);
X    stuff_flonum(lMat, 15, 1.0);
X
X    }/*endif found matrix*/
X    else
X    xlerror("arg 1 not a matrix");
X
X    return (true);
X    }/*xform06_shearMat*/
X
X
X
XLVAL
Xxform07_copyMat()
X{
X    LVAL    lSrc;
X    LVAL    lDest;
X
X    lSrc = xlgetarg();
X    if (matrixp(lSrc)) {
X    lDest = xlgetarg();
X    if (matrixp(lDest)){
X
X        lDest->n_vdata[0]->n_flonum = lSrc->n_vdata[0]->n_flonum;
X        lDest->n_vdata[1]->n_flonum = lSrc->n_vdata[1]->n_flonum;
X        lDest->n_vdata[2]->n_flonum = lSrc->n_vdata[2]->n_flonum;
X        lDest->n_vdata[3]->n_flonum = lSrc->n_vdata[3]->n_flonum;
X
X
X        lDest->n_vdata[4]->n_flonum = lSrc->n_vdata[4]->n_flonum;
X        lDest->n_vdata[5]->n_flonum = lSrc->n_vdata[5]->n_flonum;
X        lDest->n_vdata[6]->n_flonum = lSrc->n_vdata[6]->n_flonum;
X        lDest->n_vdata[7]->n_flonum = lSrc->n_vdata[7]->n_flonum;
X
X        lDest->n_vdata[8]->n_flonum = lSrc->n_vdata[8]->n_flonum;
X        lDest->n_vdata[9]->n_flonum = lSrc->n_vdata[9]->n_flonum;
X        lDest->n_vdata[10]->n_flonum = lSrc->n_vdata[10]->n_flonum;
X        lDest->n_vdata[11]->n_flonum = lSrc->n_vdata[11]->n_flonum;
X
X        lDest->n_vdata[12]->n_flonum = lSrc->n_vdata[12]->n_flonum;
X        lDest->n_vdata[13]->n_flonum = lSrc->n_vdata[13]->n_flonum;
X        lDest->n_vdata[14]->n_flonum = lSrc->n_vdata[14]->n_flonum;
X        lDest->n_vdata[15]->n_flonum = lSrc->n_vdata[15]->n_flonum;
X
X        }/*endif happy*/
X    else
X        xlerror("arg 2 not a matrix");
X    }/*endif found src matrix*/
X    else
X    xlerror("arg 1 not a matrix");
X
X    return (true);
X
X    }/*xform07_copyMat*/
X
X
X
XLVAL
Xxform04_PosQuat2Mat()
X{
X    LVAL    lPos;
X    LVAL    lQuat;
X    LVAL    lMat;
X
X     float x2, y2, z2, xx2, yy2, zz2, xy2, xz2, xw2, yw2, yz2, zw2;
X     float    fMagnitude;
X     Quaternion q;
X
X    lPos = xlgetarg();
X    if (triplep(lPos)){
X    lQuat = xlgetarg();
X    if (quaternionp(lQuat)) {
X        lMat = xlgetarg();
X        if (matrixp(lMat)) {
X
X
X        q[0] = getflonum(getelement(lQuat, 0));
X        q[1] = getflonum(getelement(getelement(lQuat,1),0));
X        q[2] = getflonum(getelement(getelement(lQuat,1),1));
X        q[3] = getflonum(getelement(getelement(lQuat,1),2));
X
X/*        fMagnitude = xform_magnitude(&(q[1]));
X        if (fMagnitude == 0.0)
X            xlerror("rotate: zero length vector");
X*/
X#ifdef DEBUG
X        fprintf(stderr, "quat after is <%f,%f,%f,%f>\n",
X            q[0], q[1], q[2], q[3]);
X#endif
X        x2 = q[1] + q[1];
X        y2 = q[2] + q[2];
X        z2 = q[3] + q[3];
X
X        xx2 = q[1] * x2;
X        yy2 = q[2] * y2;
X        zz2 = q[3] * z2;
X        xy2 = q[1] * y2;
X        xz2 = q[1] * z2;
X        yz2 = q[2] * z2;
X        xw2 = q[0] * x2;
X        yw2 = q[0] * y2;
X        zw2 = q[0] * z2;
X
X        stuff_flonum(lMat, 0, 1.0 - yy2 - zz2);
X        stuff_flonum(lMat, 1, xy2 + zw2);
X        stuff_flonum(lMat, 2,  xz2 - yw2);
X        stuff_flonum(lMat, 4, xy2 - zw2);
X        stuff_flonum(lMat, 5, 1.0 - xx2 - zz2);
X        stuff_flonum(lMat, 6, yz2 + xw2);
X        stuff_flonum(lMat, 8, xz2 + yw2);
X        stuff_flonum(lMat, 9, yz2 - xw2);
X        stuff_flonum(lMat, 10, 1.0 - xx2 - yy2);
X
X        stuff_flonum(lMat, 12, v_float(lPos,0));
X        stuff_flonum(lMat, 13, v_float(lPos,1));
X        stuff_flonum(lMat, 14, v_float(lPos,2));
X
X        stuff_flonum(lMat, 3, 0.0);
X        stuff_flonum(lMat, 7, 0.0);
X        stuff_flonum(lMat, 11, 0.0);
X        stuff_flonum(lMat, 15, 1.0);
X
X
X        }/*endif sane*/
X        else
X        xlerror("PosQuat2Mat: arg 3 not a matrix");
X        }/*endif found matrix*/
X    else
X        xlerror("PosQuat2Mat: arg 2 not a quaternion");
X    }/*endif found triple */
X    else
X    xlerror("PosQuat2Mat: arg 1 not a triple");
X
X    return (true);
X
X     }/*xform04_PosQuat2Mat*/
X
X
X
XLVAL
Xxform08_multQuats()
X{
X    Quaternion    q1;
X    Quaternion     q2;
X    Quaternion    q3;
X
X    LVAL    lQ1;
X    LVAL    lQ2;
X    LVAL    lQ3;
X    LVAL    lQ3elt;                  /* element of lQ3          */
X
X    float    fMagnitude;
X    Vector    vCrossProduct;
X
X    lQ1 = xlgetarg();
X    if (quaternionp(lQ1)) {
X    lQ2 = xlgetarg();
X    if (quaternionp(lQ2)){
X        lQ3 = xlgetarg();
X        if (quaternionp(lQ3)) {
X
X        lQ3elt = getelement(lQ3,1);      /* will need this for stuffing */
X
X        q1[0] = getflonum(getelement(lQ1, 0));
X        q1[1] = getflonum(getelement(getelement(lQ1,1),0));
X        q1[2] = getflonum(getelement(getelement(lQ1,1),1));
X        q1[3] = getflonum(getelement(getelement(lQ1,1),2));
X
X
X        q2[0] = getflonum(getelement(lQ2, 0));
X        q2[1] = getflonum(getelement(getelement(lQ2,1),0));
X        q2[2] = getflonum(getelement(getelement(lQ2,1),1));
X        q2[3] = getflonum(getelement(getelement(lQ2,1),2));
X
X        if (FEPS(q1[0],0.0)) {
X            if (!FEPS(q2[0],0.0)) {
X            stuff_flonum(lQ3, 0, q2[0]);
X            stuff_flonum(lQ3elt, 0, q2[1]);
X            stuff_flonum(lQ3elt, 1, q2[2]);
X            stuff_flonum(lQ3elt, 2, q2[3]);
X            }/*endif q1 bad, q2 good*/
X/*            else {
X            xlerror("multquats: q1 and q2 have no rotation");
X            }/*else both bad*/
X            }/*endif q1 bad*/
X        else
X            { /* q1 must be ok, so check q2 */
X            if (FEPS(q2[0],0.0)) {
X            stuff_flonum(lQ3, 0, q1[0]);
X            stuff_flonum(lQ3elt, 0, q1[1]);
X            stuff_flonum(lQ3elt, 1, q1[2]);
X            stuff_flonum(lQ3elt, 2, q1[3]);
X            }/*endif q1 ok, q2 bad*/
X            else
X            { /* else both ok*/
X/*            fMagnitude = xform_magnitude(&(q1[1]));
X            if (fMagnitude == 0.0)
X                xlerror("multquats: arg 1 zero length vector");
X
X            fMagnitude = xform_magnitude(&(q1[1]));
X            if (fMagnitude == 0.0)
X                xlerror("mulquats: arg 2 zero length vector");
X*/
X
X            vCrossProduct[0] = q1[2] * q2[3] - q1[3] * q2[2];
X            vCrossProduct[1] = q1[3] * q2[1] - q1[1] * q2[3];
X            vCrossProduct[2] = q1[1] * q2[2] - q1[2] * q2[1];
X
X
X            q3[0] = (q1[0] * q2[0]) -
X                ((q1)[1]*(q2)[1] + (q1)[2]*(q2)[2] + (q1)[3]*(q2)[3]);
X                          /* line above is dot product */
X
X            q3[1] = (q1[0] * q2[1]) + (q2[0] * q1[1]) + vCrossProduct[0];
X            q3[2] = (q1[0] * q2[2]) + (q2[0] * q1[2]) + vCrossProduct[1];
X            q3[3] = (q1[0] * q2[3]) + (q2[0] * q1[3]) + vCrossProduct[2];
X
X/*            fMagnitude = xform_magnitude(&(q3[1]));
X            if (fMagnitude == 0.0)
X                xlerror("multquats: result zero length vector");
X*/
X            stuff_flonum(lQ3, 0, q3[0]);
X            stuff_flonum(lQ3elt, 0, q3[1]);
X            stuff_flonum(lQ3elt, 1, q3[2]);
X            stuff_flonum(lQ3elt, 2, q3[3]);
X
X
X            }/*else both are ok*/
X            }/*else*/
X        }/*endif happy*/
X        else
X        xlerror("multquats: arg3 not quaternion");
X        }/*endif got quat2*/
X    else
X        xlerror("multquats, arg2 not quaternion");
X    }/*endif arg1 quat*/
X    else
X    xlerror("multquats: arg1 not quaternion");
X
X
X
X    return (true);
X
X    }/*xform08_multiplyQuats*/
X
X
X
XLVAL
Xxform09_Mat2PosQuat()
X{
X    LVAL    lPos;
X    LVAL    lQuat;
X    LVAL    lMat;
X
X    float w2, w4, x2, y2;
X    Quaternion q;
X    Matrix    m;
X
X    lMat = xlgetarg();
X    if (matrixp(lMat)) {
X    lPos = xlgetarg();
X    if (triplep(lPos)){
X        lQuat = xlgetarg();
X        if (quaternionp(lQuat)) {
X
X        w2 = 0.25 * (m_float(lMat, 0, 0) + m_float(lMat, 1, 1)
X                 + m_float(lMat, 2, 2) + m_float(lMat, 3, 3));
X        if (w2 > EPSILON)
X            {
X            q[0] = sqrt(w2);
X            w4 = 4.0 * q[0];
X            q[1] = (m_float(lMat, 1, 2) - m_float(lMat, 2, 1)) / w4;
X            q[2] = (m_float(lMat, 2, 0) - m_float(lMat, 0, 2)) / w4;
X            q[3] = (m_float(lMat, 0, 1) - m_float(lMat, 1, 0)) / w4;
X            }
X        else
X            {
X            q[0] = 0.0;
X            x2 = -0.5 * (m_float(lMat, 1, 1) + m_float(lMat, 2, 2));
X            if (x2 > EPSILON)
X            {
X            q[1] = sqrt(x2);
X            x2 = 2.0 * q[1];
X            q[2] = m_float(lMat, 0, 1) / x2;
X            q[3] = m_float(lMat, 0, 2) / x2;
X            }
X            else
X            {
X            q[1] = 0.0;
X            y2 = 0.5 * (1.0 - m_float(lMat, 2, 2));
X            if (y2 > EPSILON)
X                {
X                q[2] = sqrt(y2);
X                q[3] = m_float(lMat, 1, 2) / (2.0 * q[2]);
X                }
X            else
X                {
X                q[2] = 0.0;
X                q[3] = 1.0;
X                }
X            }
X            }
X
X        stuff_flonum(lQuat, 0, q[0]);
X        stuff_flonum(lQuat, 1, q[1]);
X        stuff_flonum(lQuat, 2, q[2]);
X        stuff_flonum(lQuat, 3, q[3]);
X
X        stuff_flonum(lPos, 0, m_float(lMat, 3, 0));
X        stuff_flonum(lPos, 1, m_float(lMat, 3, 1));
X        stuff_flonum(lPos, 2, m_float(lMat, 3, 2));
X
X
X        }/*endif sane*/
X        else
X        xlerror("Mat2Quat: arg 3 not a quaternion");
X        }/*endif found matrix*/
X    else
X        xlerror("Mat2Quat: arg 2 not a triple");
X    }/*endif found triple */
X    else
X    xlerror("Mat2Quat: arg 1 not a matrix");
X
X    return (true);
X    }/*xform09_Mat2PosQuat*/
X
X
X/* make a normalized quaternion from an angle (in radians) and a non-zero vector
X   (indicating axis of rotation).  Third argument is quaternion to return result
X   in. */
XLVAL
Xxform10_MakeQuaternion()
X{
X    LVAL    lRot;
X    LVAL    lVec;
X    LVAL    lQuat;
X
X    LVAL    lQuatElt;
X    register float    norm, mag, w, x, y, z;
X
X    lRot = xlgaflonum();
X    lVec = xlgetarg();
X    if( triplep( lVec))
X    {
X    lQuat = xlgetarg();
X    if( quaternionp( lQuat))
X    {
X        w = cos( getflonum(lRot) / 2.0) * (getflonum(lRot) < 0.0 ? -1.0 : 1.0);
X        x = getflonum( getelement( lVec, 0));
X        y = getflonum( getelement( lVec, 1));
X        z = getflonum( getelement( lVec, 2));
X
X           /* actually magnitude squared */
X        mag = x * x + y * y + z * z;
X
X        if( mag == 0.0)
X        xlerror("MakeQuaternion: vector has zero length");
X        else
X        {
X           /* normalizing factor to apply to the vector.
X              the angle element is already the RIGHT THING, so we have
X              to make magnitude 1.0 while keeping w constant */
X        norm = sqrt( (1.0 - w * w) / mag);
X
X        lQuatElt = getelement( lQuat, 1);
X        stuff_flonum( lQuat, 0, w);
X        stuff_flonum( lQuatElt, 0, x * norm);
X        stuff_flonum( lQuatElt, 1, y * norm);
X        stuff_flonum( lQuatElt, 2, z * norm);
X        }
X    }
X    else
X        xlerror("MakeQuaternion: arg3 not quaternion");
X    }
X    else
X    xlerror("MakeQuaternion: arg2 not vector");
X
X    return( true);
X}
X
X
X
X/* normalize a quaternion (the argument).  Assumes the first component, the
X   angle, is already in standard form -- cos( angle / 2).  Only fusses with
X   the vector component */
XLVAL
Xxform11_NormalizeQuaternion()
X{
X    LVAL    lQuat;
X
X    LVAL    lQuatElt;
X    register float    norm, mag, w, x, y, z;
X
X    lQuat = xlgetarg();
X    if( quaternionp( lQuat))
X    {
X    w = getflonum( getelement( lQuat, 0));
X    lQuatElt = getelement( lQuat, 1);
X    x = getflonum( getelement( lQuatElt, 0));
X    y = getflonum( getelement( lQuatElt, 1));
X    z = getflonum( getelement( lQuatElt, 2));
X
X        /* actually magnitude squared */
X    mag = x * x + y * y + z * z;
X
X    if( mag == 0.0)
X        xlerror("NormalizeQuaternion: vector part has zero length");
X    else
X    {
X            /* normalizing factor to apply to the vector.
X           the angle element is already the RIGHT THING, so we have
X           to make magnitude 1.0 while keeping w constant */
X        norm = sqrt( (1.0 - w * w) / mag);
X
X        stuff_flonum( lQuat, 0, w);
X        stuff_flonum( lQuatElt, 0, x * norm);
X        stuff_flonum( lQuatElt, 1, y * norm);
X        stuff_flonum( lQuatElt, 2, z * norm);
X    }
X    }
X    else
X    xlerror("NormalizeQuaternion: arg1 not quaternion");
X
X    return( true);
X}
X
XLVAL
Xxform12_PointTimesQuat()
X{
X    LVAL    lPoint;
X    LVAL    lQuat;
X    LVAL    lResult;
X
X    float x2, y2, z2, xx2, yy2, zz2, xy2, xz2, xw2, yw2, yz2, zw2;
X    float a, b, c;
X    Quaternion q;
X
X    lPoint = xlgetarg();
X    if (triplep(lPoint)){
X    lQuat = xlgetarg();
X    if (quaternionp(lQuat)) {
X        lResult = xlgetarg();
X        if (triplep(lResult)) {
X
X        q[0] = getflonum(getelement(lQuat, 0));
X        q[1] = getflonum(getelement(getelement(lQuat,1),0));
X        q[2] = getflonum(getelement(getelement(lQuat,1),1));
X        q[3] = getflonum(getelement(getelement(lQuat,1),2));
X
X        x2 = q[1] + q[1];
X        y2 = q[2] + q[2];
X        z2 = q[3] + q[3];
X
X        xx2 = q[1] * x2;
X        yy2 = q[2] * y2;
X        zz2 = q[3] * z2;
X        xy2 = q[1] * y2;
X        xz2 = q[1] * z2;
X        yz2 = q[2] * z2;
X        xw2 = q[0] * x2;
X        yw2 = q[0] * y2;
X        zw2 = q[0] * z2;
X
X        a = getflonum(getelement(lPoint, 0));
X        b = getflonum(getelement(lPoint, 1));
X        c = getflonum(getelement(lPoint, 2));
X
X        stuff_flonum(lResult, 0,
X                 a * (1.0 - yy2 - zz2) +
X                 b * (xy2 - zw2) +
X                 c * (xz2 + yw2));
X
X        stuff_flonum(lResult, 1,
X                 a * (xy2 + zw2) +
X                 b * (1 - xx2 - zz2) +
X                 c * (yz2 - xw2));
X
X        stuff_flonum(lResult, 2,
X                 a * (xz2 - yw2) +
X                 b * (yz2 + xw2) +
X                 c * (1 - xx2 - yy2));
X        }/*endif sane*/
X        else
X        xlerror("PointTimesQuat: arg 3 not a triple");
X        }/*endif found matrix*/
X    else
X        xlerror("PointTimesQuat: arg 2 not a quaternion");
X    }/*endif found triple */
X    else
X    xlerror("PointTimesQuat: arg 1 not a triple");
X
X    return (true);
X
X     }/* xform12_PointTimesQuat */
X
END_OF_FILE
if test 19222 -ne `wc -c <'src/utils/xform_prims.c'`; then
    echo shar: \"'src/utils/xform_prims.c'\" unpacked with wrong size!
fi
# end of 'src/utils/xform_prims.c'
fi
if test -f 'src/xlisp/xcore/c/xlbfun.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlbfun.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xlbfun.c'\" \(19033 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xlbfun.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xlbfun.c
X* RCS:          $Header: xlbfun.c,v 1.2 89/11/25 05:13:34 mayer Exp $
X* Description:  xlisp basic built-in functions
X* Author:       David Michael Betz
X* Created:
X* Modified:     Sat Nov 25 05:13:11 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: xlbfun.c,v 1.2 89/11/25 05:13:34 mayer Exp $";
X
X#include "xlisp.h"
X
X/* external variables */
Xextern LVAL xlenv,xlfenv,xldenv,true;
Xextern LVAL s_evalhook,s_applyhook;
Xextern LVAL s_car,s_cdr,s_nth,s_get,s_svalue,s_splist,s_aref;
Xextern LVAL s_lambda,s_macro;
Xextern LVAL s_comma,s_comat;
Xextern LVAL s_unbound;
Xextern char gsprefix[];
Xextern int gsnumber;
X
X/* external routines */
Xextern LVAL xlxeval();
X
X/* forward declarations */
XFORWARD LVAL bquote1();
XFORWARD LVAL defun();
XFORWARD LVAL makesymbol();
X
X/* xeval - the built-in function 'eval' */
XLVAL xeval()
X{
X    LVAL expr;
X
X    /* get the expression to evaluate */
X    expr = xlgetarg();
X    xllastarg();
X
X    /* evaluate the expression */
X    return (xleval(expr));
X}
X
X/* xapply - the built-in function 'apply' */
XLVAL xapply()
X{
X    LVAL fun,arglist;
X
X    /* get the function and argument list */
X    fun = xlgetarg();
X    arglist = xlgalist();
X    xllastarg();
X
X    /* apply the function to the arguments */
X    return (xlapply(pushargs(fun,arglist)));
X}
X
X/* xfuncall - the built-in function 'funcall' */
XLVAL xfuncall()
X{
X    LVAL *newfp;
X    int argc;
X
X    /* build a new argument stack frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(xlgetarg());
X    pusharg(NIL); /* will be argc */
X
X    /* push each argument */
X    for (argc = 0; moreargs(); ++argc)
X    pusharg(nextarg());
X
X    /* establish the new stack frame */
X    newfp[2] = cvfixnum((FIXTYPE)argc);
X    xlfp = newfp;
X
X    /* apply the function to the arguments */
X    return (xlapply(argc));
X}
X
X/* xmacroexpand - expand a macro call repeatedly */
XLVAL xmacroexpand()
X{
X    LVAL form;
X    form = xlgetarg();
X    xllastarg();
X    return (xlexpandmacros(form));
X}
X
X/* x1macroexpand - expand a macro call */
XLVAL x1macroexpand()
X{
X    LVAL form,fun,args;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(fun);
X    xlsave(args);
X
X    /* get the form */
X    form = xlgetarg();
X    xllastarg();
X
X    /* expand until the form isn't a macro call */
X    if (consp(form)) {
X    fun = car(form);        /* get the macro name */
X    args = cdr(form);        /* get the arguments */
X    if (symbolp(fun) && fboundp(fun)) {
X        fun = xlgetfunction(fun);    /* get the expansion function */
X        macroexpand(fun,args,&form);
X    }
X    }
X
X    /* restore the stack and return the expansion */
X    xlpopn(2);
X    return (form);
X}
X
X/* xatom - is this an atom? */
XLVAL xatom()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (atom(arg) ? true : NIL);
X}
X
X/* xsymbolp - is this an symbol? */
XLVAL xsymbolp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (arg == NIL || symbolp(arg) ? true : NIL);
X}
X
X/* xnumberp - is this a number? */
XLVAL xnumberp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (fixp(arg) || floatp(arg) ? true : NIL);
X}
X
X/* xintegerp - is this an integer? */
XLVAL xintegerp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (fixp(arg) ? true : NIL);
X}
X
X/* xfloatp - is this a float? */
XLVAL xfloatp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (floatp(arg) ? true : NIL);
X}
X
X/* xcharp - is this a character? */
XLVAL xcharp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (charp(arg) ? true : NIL);
X}
X
X/* xstringp - is this a string? */
XLVAL xstringp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (stringp(arg) ? true : NIL);
X}
X
X/* xarrayp - is this an array? */
XLVAL xarrayp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (vectorp(arg) ? true : NIL);
X}
X
X/* xstreamp - is this a stream? */
XLVAL xstreamp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (streamp(arg) || ustreamp(arg) ? true : NIL);
X}
X
X/* xobjectp - is this an object? */
XLVAL xobjectp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (objectp(arg) ? true : NIL);
X}
X
X/* xboundp - is there a value bound to this symbol? */
XLVAL xboundp()
X{
X    LVAL sym;
X    sym = xlgasymbol();
X    xllastarg();
X    return (boundp(sym) ? true : NIL);
X}
X
X/* xfboundp - is there a functional value bound to this symbol? */
XLVAL xfboundp()
X{
X    LVAL sym;
X    sym = xlgasymbol();
X    xllastarg();
X    return (fboundp(sym) ? true : NIL);
X}
X
X/* xnull - is this null? */
XLVAL xnull()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (null(arg) ? true : NIL);
X}
X
X/* xlistp - is this a list? */
XLVAL xlistp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (listp(arg) ? true : NIL);
X}
X
X/* xendp - is this the end of a list? */
XLVAL xendp()
X{
X    LVAL arg;
X    arg = xlgalist();
X    xllastarg();
X    return (null(arg) ? true : NIL);
X}
X
X/* xconsp - is this a cons? */
XLVAL xconsp()
X{
X    LVAL arg;
X    arg = xlgetarg();
X    xllastarg();
X    return (consp(arg) ? true : NIL);
X}
X
X/* xeq - are these equal? */
XLVAL xeq()
X{
X    LVAL arg1,arg2;
X
X    /* get the two arguments */
X    arg1 = xlgetarg();
X    arg2 = xlgetarg();
X    xllastarg();
X
X    /* compare the arguments */
X    return (arg1 == arg2 ? true : NIL);
X}
X
X/* xeql - are these equal? */
XLVAL xeql()
X{
X    LVAL arg1,arg2;
X
X    /* get the two arguments */
X    arg1 = xlgetarg();
X    arg2 = xlgetarg();
X    xllastarg();
X
X    /* compare the arguments */
X    return (eql(arg1,arg2) ? true : NIL);
X}
X
X/* xequal - are these equal? (recursive) */
XLVAL xequal()
X{
X    LVAL arg1,arg2;
X
X    /* get the two arguments */
X    arg1 = xlgetarg();
X    arg2 = xlgetarg();
X    xllastarg();
X
X    /* compare the arguments */
X    return (equal(arg1,arg2) ? true : NIL);
X}
X
X/* xset - built-in function set */
XLVAL xset()
X{
X    LVAL sym,val;
X
X    /* get the symbol and new value */
X    sym = xlgasymbol();
X    val = xlgetarg();
X    xllastarg();
X
X    /* assign the symbol the value of argument 2 */
X    setvalue(sym,val);
X
X    /* return the result value */
X    return (val);
X}
X
X/* xgensym - generate a symbol */
XLVAL xgensym()
X{
X    char sym[STRMAX+11]; /* enough space for prefix and number */
X    LVAL x;
X
X    /* get the prefix or number */
X    if (moreargs()) {
X    x = xlgetarg();
X    switch (null(x) ? CONS : ntype(x)) {
X    case SYMBOL:
X        x = getpname(x);
X                /*** FALL INTO STRING ***/
X    case STRING:
X        strncpy(gsprefix,getstring(x),STRMAX);
X        gsprefix[STRMAX] = '\0';
X        break;
X    case FIXNUM:
X        gsnumber = getfixnum(x);
X        break;
X    default:
X        xlerror("bad argument type",x);
X    }
X    }
X    xllastarg();
X
X    /* create the pname of the new symbol */
X    sprintf(sym,"%s%d",gsprefix,gsnumber++);
X
X    /* make a symbol with this print name */
X    return (xlmakesym(sym));
X}
X
X/* xmakesymbol - make a new uninterned symbol */
XLVAL xmakesymbol()
X{
X    LVAL pname;
X
X    /* get the print name of the symbol */
X    pname = xlgastring();
X    xllastarg();
X
X    /* make the symbol */
X    return xlmakesym(getstring(pname));
X}
X
X/* xintern - make a new interned symbol */
XLVAL xintern()
X{
X    LVAL pname;
X
X    /* get the print name of the symbol to intern */
X    pname = xlgastring();
X    xllastarg();
X
X    /* make the symbol */
X    return xlenter(getstring(pname));
X}
X
X/* xsymname - get the print name of a symbol */
XLVAL xsymname()
X{
X    LVAL sym;
X
X    /* get the symbol */
X    sym = xlgasymbol();
X    xllastarg();
X
X    /* return the print name */
X    return (getpname(sym));
X}
X
X/* xsymvalue - get the value of a symbol */
XLVAL xsymvalue()
X{
X    LVAL sym,val;
X
X    /* get the symbol */
X    sym = xlgasymbol();
X    xllastarg();
X
X    /* get the global value */
X    while ((val = getvalue(sym)) == s_unbound)
X    xlunbound(sym);
X
X    /* return its value */
X    return (val);
X}
X
X/* xsymfunction - get the functional value of a symbol */
XLVAL xsymfunction()
X{
X    LVAL sym,val;
X
X    /* get the symbol */
X    sym = xlgasymbol();
X    xllastarg();
X
X    /* get the global value */
X    while ((val = getfunction(sym)) == s_unbound)
X    xlfunbound(sym);
X
X    /* return its value */
X    return (val);
X}
X
X/* xsymplist - get the property list of a symbol */
XLVAL xsymplist()
X{
X    LVAL sym;
X
X    /* get the symbol */
X    sym = xlgasymbol();
X    xllastarg();
X
X    /* return the property list */
X    return (getplist(sym));
X}
X
X/* xget - get the value of a property */
XLVAL xget()
X{
X    LVAL sym,prp;
X
X    /* get the symbol and property */
X    sym = xlgasymbol();
X    prp = xlgasymbol();
X    xllastarg();
X
X    /* retrieve the property value */
X    return (xlgetprop(sym,prp));
X}
X
X/* xputprop - set the value of a property */
XLVAL xputprop()
X{
X    LVAL sym,val,prp;
X
X    /* get the symbol and property */
X    sym = xlgasymbol();
X    val = xlgetarg();
X    prp = xlgasymbol();
X    xllastarg();
X
X    /* set the property value */
X    xlputprop(sym,val,prp);
X
X    /* return the value */
X    return (val);
X}
X
X/* xremprop - remove a property value from a property list */
XLVAL xremprop()
X{
X    LVAL sym,prp;
X
X    /* get the symbol and property */
X    sym = xlgasymbol();
X    prp = xlgasymbol();
X    xllastarg();
X
X    /* remove the property */
X    xlremprop(sym,prp);
X
X    /* return nil */
X    return (NIL);
X}
X
X/* xhash - compute the hash value of a string or symbol */
XLVAL xhash()
X{
X    unsigned char *str;
X    LVAL len,val;
X    int n;
X
X    /* get the string and the table length */
X    val = xlgetarg();
X    len = xlgafixnum(); n = (int)getfixnum(len);
X    xllastarg();
X
X    /* get the string */
X    if (symbolp(val))
X    str = getstring(getpname(val));
X    else if (stringp(val))
X    str = getstring(val);
X    else
X    xlerror("bad argument type",val);
X
X    /* return the hash index */
X    return (cvfixnum((FIXTYPE)hash(str,n)));
X}
X
X/* xaref - array reference function */
XLVAL xaref()
X{
X    LVAL array,index;
X    int i;
X
X    /* get the array and the index */
X    array = xlgavector();
X    index = xlgafixnum(); i = (int)getfixnum(index);
X    xllastarg();
X
X    /* range check the index */
X    if (i < 0 || i >= getsz(array))
X    xlerror("array index out of bounds",index);
X
X    /* return the array element */
X    return (getelement(array,i));
X}
X
X/* xmkarray - make a new array */
XLVAL xmkarray()
X{
X    LVAL size;
X    int n;
X
X    /* get the size of the array */
X    size = xlgafixnum() ; n = (int)getfixnum(size);
X    xllastarg();
X
X    /* create the array */
X    return (newvector(n));
X}
X
X/* xvector - make a vector */
XLVAL xvector()
X{
X    LVAL val;
X    int i;
X
X    /* make the vector */
X    val = newvector(xlargc);
X
X    /* store each argument */
X    for (i = 0; moreargs(); ++i)
X    setelement(val,i,nextarg());
X    xllastarg();
X
X    /* return the vector */
X    return (val);
X}
X
X/******************************************************************************
X * (copy-array <src> <dest> [<pos>]) --> returns <dest>
X * This function copies from array <src> into the preallocated array <dest>
X * (allocate with 'make-array'). If the optional arg <pos> is given, then
X * elements from <src> will be written into <dest> at index <pos>, otherwise
X * <pos> defaults to 0.
X *
X * This function was added to xlisp by Niels Mayer.
X ******************************************************************************/
XLVAL Prim_COPY_ARRAY()
X{
X  register int size;
X  register LVAL *src, *dest;
X  LVAL src_array, dest_array, lval_pos;
X
X  src_array = xlgavector();    /* get <src> */
X  dest_array = xlgavector();    /* get <dest> */
X  if moreargs()
X    lval_pos = xlgafixnum();    /* get optional <pos> */
X  else
X    lval_pos = NIL;
X  xllastarg();
X
X  src = src_array->n_vdata;
X  dest = dest_array->n_vdata;
X
X  if (getsz(src_array) < getsz(dest_array))    /* which is shortest? */
X    size = getsz(src_array);
X  else
X    size = getsz(dest_array);
X
X  if (lval_pos) {
X    int pos = getfixnum(lval_pos);
X    int len = getsz(dest_array) - pos;
X    if ((len <= 0) || (pos < 0))
X      xlerror("Array position out of bounds.", lval_pos);
X    if (len < size)
X      size = len;
X    dest = dest + pos;
X  }
X
X  while (size--)
X    *dest++ = *src++;
X
X  return (dest_array);
X}
X
X/******************************************************************************
X * (array-insert-pos <array> <pos> <elt>) --> returns the new <array>
X * inserts <elt> at index <pos> in <array>. if <pos> < 0, then <elt> is
X * appended to the end of <array>.
X *
X * This function was added to xlisp by Niels Mayer.
X ******************************************************************************/
XLVAL Prim_ARRAY_INSERT_POS()
X{
X  register int i;
X  register LVAL *src, *dest;
X  LVAL src_array, dest_array, elt, lval_position;
X  int src_size, position;
X
X  src_array = xlgavector();    /* get <array> */
X  lval_position = xlgafixnum();    /* get <pos>, a fixnum */
X  elt = nextarg();        /* get <elt>, which can be any lisp type */
X  xllastarg();
X
X  src_size = getsz(src_array);
X  position = getfixnum(lval_position);
X  if (position >= src_size)
X    xlerror("Array insertion position out of bounds.", lval_position);
X  dest_array = newvector(src_size + 1);
X
X  src = src_array->n_vdata;
X  dest = dest_array->n_vdata;
X
X  if (position < 0) {        /* append <elt> to end of array */
X    i = src_size;
X    while (i--)
X      *dest++ = *src++;
X    *dest = elt;
X  }
X  else {            /* insert <elt> at <position> */
X    i = position;
X    while (i--)
X      *dest++ = *src++;
X    *dest++ = elt;
X    i = src_size - position;
X    while (i--)
X      *dest++ = *src++;
X  }
X  return (dest_array);
X}
X
X/******************************************************************************
X * (array-delete-pos <array> <pos>) --> returns the new <array>
X * deletes the element at index <pos> in <array>. If <pos>==-1, then it
X * will delete the last element in the array.
X * Note that this function is destructive. It reuses the old <array>'s
X * elements.
X *
X * This function was added to xlisp by Niels Mayer.
X ******************************************************************************/
XLVAL Prim_ARRAY_DELETE_POS()
X{
X  register int i;
X  register LVAL *src, *dest;
X  LVAL src_array, dest_array, lval_position;
X  int src_size, position;
X
X  src_array = xlgavector();    /* get <array> */
X  lval_position = xlgafixnum();    /* get <pos>, a fixnum */
X  xllastarg();
X
X  src_size = getsz(src_array);
X  position = getfixnum(lval_position);
X  if (position >= src_size)
X    xlerror("Array insertion position out of bounds.", lval_position);
X  if ((src_size - 1) > 0)
X    dest_array = newvector(src_size - 1);
X  else
X    return (NIL);
X
X  src = src_array->n_vdata;
X  dest = dest_array->n_vdata;
X
X  if (position < 0) {        /* remove last element of array */
X    i = src_size - 1;
X    while (i--)
X      *dest++ = *src++;
X  }
X  else {            /* remove <elt> at <position> */
X    i = position;
X    while (i--)
X      *dest++ = *src++;
X    src++;            /* don't copy the deleted elt */
X    i = src_size - (position + 1);
X    while (i--)
X      *dest++ = *src++;
X  }
X  return (dest_array);
X}
X
X/* xerror - special form 'error' */
XLVAL xerror()
X{
X    LVAL emsg,arg;
X
X    /* get the error message and the argument */
X    emsg = xlgastring();
X    arg = (moreargs() ? xlgetarg() : s_unbound);
X    xllastarg();
X
X    /* signal the error */
X    xlerror(getstring(emsg),arg);
X}
X
X/* xcerror - special form 'cerror' */
XLVAL xcerror()
X{
X    LVAL cmsg,emsg,arg;
X
X    /* get the correction message, the error message, and the argument */
X    cmsg = xlgastring();
X    emsg = xlgastring();
X    arg = (moreargs() ? xlgetarg() : s_unbound);
X    xllastarg();
X
X    /* signal the error */
X    xlcerror(getstring(cmsg),getstring(emsg),arg);
X
X    /* return nil */
X    return (NIL);
X}
X
X/* xbreak - special form 'break' */
XLVAL xbreak()
X{
X    LVAL emsg,arg;
X
X    /* get the error message */
X    emsg = (moreargs() ? xlgastring() : NIL);
X    arg = (moreargs() ? xlgetarg() : s_unbound);
X    xllastarg();
X
X    /* enter the break loop */
X    xlbreak((emsg ? getstring(emsg) : (unsigned char *)"**BREAK**"),arg);
X
X    /* return nil */
X    return (NIL);
X}
X
X/* xcleanup - special form 'clean-up' */
XLVAL xcleanup()
X{
X    xllastarg();
X    xlcleanup();
X}
X
X/* xtoplevel - special form 'top-level' */
XLVAL xtoplevel()
X{
X    xllastarg();
X    xltoplevel();
X}
X
X/* xcontinue - special form 'continue' */
XLVAL xcontinue()
X{
X    xllastarg();
X    xlcontinue();
X}
X
X/* xevalhook - eval hook function */
XLVAL xevalhook()
X{
X    LVAL expr,newehook,newahook,newenv,oldenv,oldfenv,olddenv,val;
X
X    /* protect some pointers */
X    xlstkcheck(3);
X    xlsave(oldenv);
X    xlsave(oldfenv);
X    xlsave(newenv);
X
X    /* get the expression, the new hook functions and the environment */
X    expr = xlgetarg();
X    newehook = xlgetarg();
X    newahook = xlgetarg();
X    newenv = (moreargs() ? xlgalist() : NIL);
X    xllastarg();
X
X    /* bind *evalhook* and *applyhook* to the hook functions */
X    olddenv = xldenv;
X    xldbind(s_evalhook,newehook);
X    xldbind(s_applyhook,newahook);
X
X    /* establish the environment for the hook function */
X    if (newenv) {
X    oldenv = xlenv;
X    oldfenv = xlfenv;
X    xlenv = car(newenv);
X    xlfenv = cdr(newenv);
X    }
X
X    /* evaluate the expression (bypassing *evalhook*) */
X    val = xlxeval(expr);
X
X    /* restore the old environment */
X    xlunbind(olddenv);
X    if (newenv) {
X    xlenv = oldenv;
X    xlfenv = oldfenv;
X    }
X
X    /* restore the stack */
X    xlpopn(3);
X
X    /* return the result */
X    return (val);
X}
X
END_OF_FILE
if test 19033 -ne `wc -c <'src/xlisp/xcore/c/xlbfun.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xlbfun.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xlbfun.c'
fi
if test -f 'src/xlisp/xcore/c/xllist.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xllist.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xllist.c'\" \(20721 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xllist.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xllist.c
X* RCS:          $Header: xllist.c,v 1.2 89/11/25 05:39:25 mayer Exp $
X* Description:  xlisp built-in list functions
X* Author:       David Michael Betz
X* Created:
X* Modified:     Sat Nov 25 05:39: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: xllist.c,v 1.2 89/11/25 05:39:25 mayer Exp $";
X
X
X#include "xlisp.h"
X
X/* forward declarations */
XFORWARD LVAL cxr();
XFORWARD LVAL nth(),assoc();
XFORWARD LVAL subst(),sublis(),map();
X
X/* xcar - take the car of a cons cell */
XLVAL xcar()
X{
X    LVAL list;
X    list = xlgalist();
X    xllastarg();
X    return (list ? car(list) : NIL);
X}
X
X/* xcdr - take the cdr of a cons cell */
XLVAL xcdr()
X{
X    LVAL list;
X    list = xlgalist();
X    xllastarg();
X    return (list ? cdr(list) : NIL);
X}
X
X/* cxxr functions */
XLVAL xcaar() { return (cxr("aa")); }
XLVAL xcadr() { return (cxr("da")); }
XLVAL xcdar() { return (cxr("ad")); }
XLVAL xcddr() { return (cxr("dd")); }
X
X/* cxxxr functions */
XLVAL xcaaar() { return (cxr("aaa")); }
XLVAL xcaadr() { return (cxr("daa")); }
XLVAL xcadar() { return (cxr("ada")); }
XLVAL xcaddr() { return (cxr("dda")); }
XLVAL xcdaar() { return (cxr("aad")); }
XLVAL xcdadr() { return (cxr("dad")); }
XLVAL xcddar() { return (cxr("add")); }
XLVAL xcdddr() { return (cxr("ddd")); }
X
X/* cxxxxr functions */
XLVAL xcaaaar() { return (cxr("aaaa")); }
XLVAL xcaaadr() { return (cxr("daaa")); }
XLVAL xcaadar() { return (cxr("adaa")); }
XLVAL xcaaddr() { return (cxr("ddaa")); }
XLVAL xcadaar() { return (cxr("aada")); }
XLVAL xcadadr() { return (cxr("dada")); }
XLVAL xcaddar() { return (cxr("adda")); }
XLVAL xcadddr() { return (cxr("ddda")); }
XLVAL xcdaaar() { return (cxr("aaad")); }
XLVAL xcdaadr() { return (cxr("daad")); }
XLVAL xcdadar() { return (cxr("adad")); }
XLVAL xcdaddr() { return (cxr("ddad")); }
XLVAL xcddaar() { return (cxr("aadd")); }
XLVAL xcddadr() { return (cxr("dadd")); }
XLVAL xcdddar() { return (cxr("addd")); }
XLVAL xcddddr() { return (cxr("dddd")); }
X
X/* cxr - common car/cdr routine */
XLOCAL LVAL cxr(adstr)
X  char *adstr;
X{
X    LVAL list;
X
X    /* get the list */
X    list = xlgalist();
X    xllastarg();
X
X    /* perform the car/cdr operations */
X    while (*adstr && consp(list))
X    list = (*adstr++ == 'a' ? car(list) : cdr(list));
X
X    /* make sure the operation succeeded */
X    if (*adstr && list)
X    xlfail("bad argument");
X
X    /* return the result */
X    return (list);
X}
X
X/* xcons - construct a new list cell */
XLVAL xcons()
X{
X    LVAL arg1,arg2;
X
X    /* get the two arguments */
X    arg1 = xlgetarg();
X    arg2 = xlgetarg();
X    xllastarg();
X
X    /* construct a new list element */
X    return (cons(arg1,arg2));
X}
X
X/* xlist - built a list of the arguments */
XLVAL xlist()
X{
X    LVAL last,next,val;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* add each argument to the list */
X    for (val = NIL; moreargs(); ) {
X
X    /* append this argument to the end of the list */
X    next = consa(nextarg());
X    if (val) rplacd(last,next);
X    else val = next;
X    last = next;
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the list */
X    return (val);
X}
X
X/* xappend - built-in function append */
XLVAL xappend()
X{
X    LVAL list,last,next,val;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* initialize */
X    val = NIL;
X
X    /* append each argument */
X    if (moreargs()) {
X    while (xlargc > 1) {
X
X        /* append each element of this list to the result list */
X        for (list = nextarg(); consp(list); list = cdr(list)) {
X        next = consa(car(list));
X        if (val) rplacd(last,next);
X        else val = next;
X        last = next;
X        }
X    }
X
X    /* handle the last argument */
X    if (val) rplacd(last,nextarg());
X    else val = nextarg();
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the list */
X    return (val);
X}
X
X/* xreverse - built-in function reverse */
XLVAL xreverse()
X{
X    LVAL list,val;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* get the list to reverse */
X    list = xlgalist();
X    xllastarg();
X
X    /* append each element to the head of the result list */
X    for (val = NIL; consp(list); list = cdr(list))
X    val = cons(car(list),val);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the list */
X    return (val);
X}
X
X/* xlast - return the last cons of a list */
XLVAL xlast()
X{
X    LVAL list;
X
X    /* get the list */
X    list = xlgalist();
X    xllastarg();
X
X    /* find the last cons */
X    while (consp(list) && cdr(list))
X    list = cdr(list);
X
X    /* return the last element */
X    return (list);
X}
X
X/* xmember - built-in function 'member' */
XLVAL xmember()
X{
X    LVAL x,list,fcn,val;
X    int tresult;
X
X    /* protect some pointers */
X    xlsave1(fcn);
X
X    /* get the expression to look for and the list */
X    x = xlgetarg();
X    list = xlgalist();
X    xltest(&fcn,&tresult);
X
X    /* look for the expression */
X    for (val = NIL; consp(list); list = cdr(list))
X    if (dotest2(x,car(list),fcn) == tresult) {
X        val = list;
X        break;
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* xassoc - built-in function 'assoc' */
XLVAL xassoc()
X{
X    LVAL x,alist,fcn,pair,val;
X    int tresult;
X
X    /* protect some pointers */
X    xlsave1(fcn);
X
X    /* get the expression to look for and the association list */
X    x = xlgetarg();
X    alist = xlgalist();
X    xltest(&fcn,&tresult);
X
X    /* look for the expression */
X    for (val = NIL; consp(alist); alist = cdr(alist))
X    if ((pair = car(alist)) && consp(pair))
X        if (dotest2(x,car(pair),fcn) == tresult) {
X        val = pair;
X        break;
X        }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return result */
X    return (val);
X}
X
X/* xsubst - substitute one expression for another */
XLVAL xsubst()
X{
X    LVAL to,from,expr,fcn,val;
X    int tresult;
X
X    /* protect some pointers */
X    xlsave1(fcn);
X
X    /* get the to value, the from value and the expression */
X    to = xlgetarg();
X    from = xlgetarg();
X    expr = xlgetarg();
X    xltest(&fcn,&tresult);
X
X    /* do the substitution */
X    val = subst(to,from,expr,fcn,tresult);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* subst - substitute one expression for another */
XLOCAL LVAL subst(to,from,expr,fcn,tresult)
X  LVAL to,from,expr,fcn; int tresult;
X{
X    LVAL carval,cdrval;
X
X    if (dotest2(expr,from,fcn) == tresult)
X    return (to);
X    else if (consp(expr)) {
X    xlsave1(carval);
X    carval = subst(to,from,car(expr),fcn,tresult);
X    cdrval = subst(to,from,cdr(expr),fcn,tresult);
X    xlpop();
X    return (cons(carval,cdrval));
X    }
X    else
X    return (expr);
X}
X
X/* xsublis - substitute using an association list */
XLVAL xsublis()
X{
X    LVAL alist,expr,fcn,val;
X    int tresult;
X
X    /* protect some pointers */
X    xlsave1(fcn);
X
X    /* get the assocation list and the expression */
X    alist = xlgalist();
X    expr = xlgetarg();
X    xltest(&fcn,&tresult);
X
X    /* do the substitution */
X    val = sublis(alist,expr,fcn,tresult);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the result */
X    return (val);
X}
X
X/* sublis - substitute using an association list */
XLOCAL LVAL sublis(alist,expr,fcn,tresult)
X  LVAL alist,expr,fcn; int tresult;
X{
X    LVAL carval,cdrval,pair;
X
X    if (pair = assoc(expr,alist,fcn,tresult))
X    return (cdr(pair));
X    else if (consp(expr)) {
X    xlsave1(carval);
X    carval = sublis(alist,car(expr),fcn,tresult);
X    cdrval = sublis(alist,cdr(expr),fcn,tresult);
X    xlpop();
X    return (cons(carval,cdrval));
X    }
X    else
X    return (expr);
X}
X
X/* assoc - find a pair in an association list */
XLOCAL LVAL assoc(expr,alist,fcn,tresult)
X  LVAL expr,alist,fcn; int tresult;
X{
X    LVAL pair;
X
X    for (; consp(alist); alist = cdr(alist))
X    if ((pair = car(alist)) && consp(pair))
X        if (dotest2(expr,car(pair),fcn) == tresult)
X        return (pair);
X    return (NIL);
X}
X
X/* xremove - built-in function 'remove' */
XLVAL xremove()
X{
X    LVAL x,list,fcn,val,last,next;
X    int tresult;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(fcn);
X    xlsave(val);
X
X    /* get the expression to remove and the list */
X    x = xlgetarg();
X    list = xlgalist();
X    xltest(&fcn,&tresult);
X
X    /* remove matches */
X    for (; consp(list); list = cdr(list))
X
X    /* check to see if this element should be deleted */
X    if (dotest2(x,car(list),fcn) != tresult) {
X        next = consa(car(list));
X        if (val) rplacd(last,next);
X        else val = next;
X        last = next;
X    }
X
X    /* restore the stack */
X    xlpopn(2);
X
X    /* return the updated list */
X    return (val);
X}
X
X/* xremif - built-in function 'remove-if' */
XLVAL xremif()
X{
X    LVAL remif();
X    return (remif(TRUE));
X}
X
X/* xremifnot - built-in function 'remove-if-not' */
XLVAL xremifnot()
X{
X    LVAL remif();
X    return (remif(FALSE));
X}
X
X/* remif - common code for 'remove-if' and 'remove-if-not' */
XLOCAL LVAL remif(tresult)
X  int tresult;
X{
X    LVAL list,fcn,val,last,next;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(fcn);
X    xlsave(val);
X
X    /* get the expression to remove and the list */
X    fcn = xlgetarg();
X    list = xlgalist();
X    xllastarg();
X
X    /* remove matches */
X    for (; consp(list); list = cdr(list))
X
X    /* check to see if this element should be deleted */
X    if (dotest1(car(list),fcn) != tresult) {
X        next = consa(car(list));
X        if (val) rplacd(last,next);
X        else val = next;
X        last = next;
X    }
X
X    /* restore the stack */
X    xlpopn(2);
X
X    /* return the updated list */
X    return (val);
X}
X
X/* dotest1 - call a test function with one argument */
Xint dotest1(arg,fun)
X  LVAL arg,fun;
X{
X    LVAL *newfp;
X
X    /* create the new call frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(fun);
X    pusharg(cvfixnum((FIXTYPE)1));
X    pusharg(arg);
X    xlfp = newfp;
X
X    /* return the result of applying the test function */
X    return (xlapply(1) != NIL);
X
X}
X
X/* dotest2 - call a test function with two arguments */
Xint dotest2(arg1,arg2,fun)
X  LVAL arg1,arg2,fun;
X{
X    LVAL *newfp;
X
X    /* create the new call frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(fun);
X    pusharg(cvfixnum((FIXTYPE)2));
X    pusharg(arg1);
X    pusharg(arg2);
X    xlfp = newfp;
X
X    /* return the result of applying the test function */
X    return (xlapply(2) != NIL);
X
X}
X
X/* xnth - return the nth element of a list */
XLVAL xnth()
X{
X    return (nth(TRUE));
X}
X
X/* xnthcdr - return the nth cdr of a list */
XLVAL xnthcdr()
X{
X    return (nth(FALSE));
X}
X
X/* nth - internal nth function */
XLOCAL LVAL nth(carflag)
X  int carflag;
X{
X    LVAL list,num;
X    FIXTYPE n;
X
X    /* get n and the list */
X    num = xlgafixnum();
X    list = xlgacons();
X    xllastarg();
X
X    /* make sure the number isn't negative */
X    if ((n = getfixnum(num)) < 0)
X    xlfail("bad argument");
X
X    /* find the nth element */
X    while (consp(list) && --n >= 0)
X    list = cdr(list);
X
X    /* return the list beginning at the nth element */
X    return (carflag && consp(list) ? car(list) : list);
X}
X
X/* xlength - return the length of a list or string */
XLVAL xlength()
X{
X    FIXTYPE n;
X    LVAL arg;
X
X    /* get the list or string */
X    arg = xlgetarg();
X    xllastarg();
X
X    /* find the length of a list */
X    if (listp(arg))
X    for (n = 0; consp(arg); n++)
X        arg = cdr(arg);
X
X    /* find the length of a string */
X    else if (stringp(arg))
X    n = (FIXTYPE)getslength(arg)-1;
X
X    /* find the length of a vector */
X    else if (vectorp(arg))
X    n = (FIXTYPE)getsz(arg);
X
X    /* otherwise, bad argument type */
X    else
X    xlerror("bad argument type",arg);
X
X    /* return the length */
X    return (cvfixnum(n));
X}
X
X/* xmapc - built-in function 'mapc' */
XLVAL xmapc()
X{
X    return (map(TRUE,FALSE));
X}
X
X/* xmapcar - built-in function 'mapcar' */
XLVAL xmapcar()
X{
X    return (map(TRUE,TRUE));
X}
X
X/* xmapl - built-in function 'mapl' */
XLVAL xmapl()
X{
X    return (map(FALSE,FALSE));
X}
X
X/* xmaplist - built-in function 'maplist' */
XLVAL xmaplist()
X{
X    return (map(FALSE,TRUE));
X}
X
X/* map - internal mapping function */
XLOCAL LVAL map(carflag,valflag)
X  int carflag,valflag;
X{
X    LVAL *newfp,fun,lists,val,last,p,x,y;
X    int argc;
X
X    /* protect some pointers */
X    xlstkcheck(3);
X    xlsave(fun);
X    xlsave(lists);
X    xlsave(val);
X
X    /* get the function to apply and the first list */
X    fun = xlgetarg();
X    lists = xlgalist();
X
X    /* initialize the result list */
X    val = (valflag ? NIL : lists);
X
X    /* build a list of argument lists */
X    for (lists = last = consa(lists); moreargs(); last = cdr(last))
X    rplacd(last,cons(xlgalist(),NIL));
X
X    /* loop through each of the argument lists */
X    for (;;) {
X
X    /* build an argument list from the sublists */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(fun);
X    pusharg(NIL);
X    argc = 0;
X    for (x = lists; x && (y = car(x)) && consp(y); x = cdr(x)) {
X        pusharg(carflag ? car(y) : y);
X        rplaca(x,cdr(y));
X        ++argc;
X    }
X
X    /* quit if any of the lists were empty */
X    if (x) {
X        xlsp = newfp;
X        break;
X    }
X
X    /* apply the function to the arguments */
X    newfp[2] = cvfixnum((FIXTYPE)argc);
X    xlfp = newfp;
X    if (valflag) {
X        p = consa(xlapply(argc));
X        if (val) rplacd(last,p);
X        else val = p;
X        last = p;
X    }
X    else
X        xlapply(argc);
X    }
X
X    /* restore the stack */
X    xlpopn(3);
X
X    /* return the last test expression value */
X    return (val);
X}
X
X/* xrplca - replace the car of a list node */
XLVAL xrplca()
X{
X    LVAL list,newcar;
X
X    /* get the list and the new car */
X    list = xlgacons();
X    newcar = xlgetarg();
X    xllastarg();
X
X    /* replace the car */
X    rplaca(list,newcar);
X
X    /* return the list node that was modified */
X    return (list);
X}
X
X/* xrplcd - replace the cdr of a list node */
XLVAL xrplcd()
X{
X    LVAL list,newcdr;
X
X    /* get the list and the new cdr */
X    list = xlgacons();
X    newcdr = xlgetarg();
X    xllastarg();
X
X    /* replace the cdr */
X    rplacd(list,newcdr);
X
X    /* return the list node that was modified */
X    return (list);
X}
X
X/* xnconc - destructively append lists */
XLVAL xnconc()
X{
X    LVAL next,last,val;
X
X    /* initialize */
X    val = NIL;
X
X    /* concatenate each argument */
X    if (moreargs()) {
X    while (xlargc > 1) {
X
X        /* ignore everything except lists */
X        if ((next = nextarg()) && consp(next)) {
X
X        /* concatenate this list to the result list */
X        if (val) rplacd(last,next);
X        else val = next;
X
X        /* find the end of the list */
X        while (consp(cdr(next)))
X            next = cdr(next);
X        last = next;
X        }
X    }
X
X    /* handle the last argument */
X    if (val) rplacd(last,nextarg());
X    else val = nextarg();
X    }
X
X    /* return the list */
X    return (val);
X}
X
X/* xdelete - built-in function 'delete' */
XLVAL xdelete()
X{
X    LVAL x,list,fcn,last,val;
X    int tresult;
X
X    /* protect some pointers */
X    xlsave1(fcn);
X
X    /* get the expression to delete and the list */
X    x = xlgetarg();
X    list = xlgalist();
X    xltest(&fcn,&tresult);
X
X    /* delete leading matches */
X    while (consp(list)) {
X    if (dotest2(x,car(list),fcn) != tresult)
X        break;
X    list = cdr(list);
X    }
X    val = last = list;
X
X    /* delete embedded matches */
X    if (consp(list)) {
X
X    /* skip the first non-matching element */
X    list = cdr(list);
X
X    /* look for embedded matches */
X    while (consp(list)) {
X
X        /* check to see if this element should be deleted */
X        if (dotest2(x,car(list),fcn) == tresult)
X        rplacd(last,cdr(list));
X        else
X        last = list;
X
X        /* move to the next element */
X        list = cdr(list);
X     }
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the updated list */
X    return (val);
X}
X
X/* xdelif - built-in function 'delete-if' */
XLVAL xdelif()
X{
X    LVAL delif();
X    return (delif(TRUE));
X}
X
X/* xdelifnot - built-in function 'delete-if-not' */
XLVAL xdelifnot()
X{
X    LVAL delif();
X    return (delif(FALSE));
X}
X
X/* delif - common routine for 'delete-if' and 'delete-if-not' */
XLOCAL LVAL delif(tresult)
X  int tresult;
X{
X    LVAL list,fcn,last,val;
X
X    /* protect some pointers */
X    xlsave1(fcn);
X
X    /* get the expression to delete and the list */
X    fcn = xlgetarg();
X    list = xlgalist();
X    xllastarg();
X
X    /* delete leading matches */
X    while (consp(list)) {
X    if (dotest1(car(list),fcn) != tresult)
X        break;
X    list = cdr(list);
X    }
X    val = last = list;
X
X    /* delete embedded matches */
X    if (consp(list)) {
X
X    /* skip the first non-matching element */
X    list = cdr(list);
X
X    /* look for embedded matches */
X    while (consp(list)) {
X
X        /* check to see if this element should be deleted */
X        if (dotest1(car(list),fcn) == tresult)
X        rplacd(last,cdr(list));
X        else
X        last = list;
X
X        /* move to the next element */
X        list = cdr(list);
X     }
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the updated list */
X    return (val);
X}
X
X/* xsort - built-in function 'sort' */
XLVAL xsort()
X{
X    LVAL sortlist();
X    LVAL list,fcn;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(list);
X    xlsave(fcn);
X
X    /* get the list to sort and the comparison function */
X    list = xlgalist();
X    fcn = xlgetarg();
X    xllastarg();
X
X    /* sort the list */
X    list = sortlist(list,fcn);
X
X    /* restore the stack and return the sorted list */
X    xlpopn(2);
X    return (list);
X}
X
X/*
X    This sorting algorithm is based on a Modula-2 sort written by
X    Richie Bielak and published in the February 1988 issue of
X    "Computer Language" magazine in a letter to the editor.
X*/
X
X/* sortlist - sort a list using quicksort */
XLOCAL LVAL sortlist(list,fcn)
X  LVAL list,fcn;
X{
X    LVAL gluelists();
X    LVAL smaller,pivot,larger;
X
X    /* protect some pointers */
X    xlstkcheck(3);
X    xlsave(smaller);
X    xlsave(pivot);
X    xlsave(larger);
X
X    /* lists with zero or one element are already sorted */
X    if (consp(list) && consp(cdr(list))) {
X    pivot = list; list = cdr(list);
X    splitlist(pivot,list,&smaller,&larger,fcn);
X    smaller = sortlist(smaller,fcn);
X    larger = sortlist(larger,fcn);
X    list = gluelists(smaller,pivot,larger);
X    }
X
X    /* cleanup the stack and return the sorted list */
X    xlpopn(3);
X    return (list);
X}
X
X/* splitlist - split the list around the pivot */
XLOCAL splitlist(pivot,list,psmaller,plarger,fcn)
X  LVAL pivot,list,*psmaller,*plarger,fcn;
X{
X    LVAL next;
X
X    /* initialize the result lists */
X    *psmaller = *plarger = NIL;
X
X    /* split the list */
X    for (; consp(list); list = next) {
X    next = cdr(list);
X    if (dotest2(car(list),car(pivot),fcn)) {
X        rplacd(list,*psmaller);
X        *psmaller = list;
X    }
X    else {
X        rplacd(list,*plarger);
X        *plarger = list;
X    }
X    }
X}
X
X/* gluelists - glue the smaller and larger lists with the pivot */
XLOCAL LVAL gluelists(smaller,pivot,larger)
X  LVAL smaller,pivot,larger;
X{
X    LVAL last;
X
X    /* larger always goes after the pivot */
X    rplacd(pivot,larger);
X
X    /* if the smaller list is empty, we're done */
X    if (null(smaller))
X    return (pivot);
X
X    /* append the smaller to the front of the resulting list */
X    for (last = smaller; consp(cdr(last)); last = cdr(last))
X    ;
X    rplacd(last,pivot);
X    return (smaller);
X}
END_OF_FILE
if test 20721 -ne `wc -c <'src/xlisp/xcore/c/xllist.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xllist.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xllist.c'
fi
if test -f 'src/xlisp/xcore/c/xlread.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlread.c'\"
else
echo shar: Extracting \"'src/xlisp/xcore/c/xlread.c'\" \(19982 characters\)
sed "s/^X//" >'src/xlisp/xcore/c/xlread.c' <<'END_OF_FILE'
X/* -*-C-*-
X********************************************************************************
X*
X* File:         xlread.c
X* RCS:          $Header: xlread.c,v 1.3 89/11/25 05:43:32 mayer Exp $
X* Description:  xlisp expression input routine
X* Author:       David Michael Betz
X* Created:
X* Modified:     Sat Nov 25 05:43:19 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*/
X static char *rcs_identity = "@(#)$Header: xlread.c,v 1.3 89/11/25 05:43:32 mayer Exp $";
X
X
X#include "xlisp.h"
X
X/* symbol parser modes */
X#define DONE    0
X#define NORMAL    1
X#define ESCAPE    2
X
X/* external variables */
Xextern LVAL s_stdout,true,s_dot;
Xextern LVAL s_quote,s_function,s_bquote,s_comma,s_comat;
Xextern LVAL s_rtable,k_wspace,k_const,k_nmacro,k_tmacro;
Xextern LVAL k_sescape,k_mescape;
Xextern char buf[];
X
X/* external routines */
Xextern FILE *osaopen();
Xextern double atof();
Xextern ITYPE;
Xextern LVAL s_unbound;
X
X#define WSPACE "\t \f\r\n"
X#define CONST1 "!$%&*+-./0123456789:<=>?@[]^_{}~"
X#define CONST2 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"
X
X/* forward declarations */
XFORWARD LVAL callmacro();
XFORWARD LVAL psymbol(),punintern();
XFORWARD LVAL pnumber(),pquote(),plist(),pvector(),pstruct();
XFORWARD LVAL readlist(),tentry();
X
X/* xlload - load a file of xlisp expressions */
Xint xlload(fname,vflag,pflag)
X  char *fname; int vflag,pflag;
X{
X    char fullname[STRMAX+1];
X    LVAL fptr,expr,path;
X    CONTEXT cntxt;
X    FILE *fp;
X    int sts;
X
X    /* protect some pointers */
X    xlstkcheck(3);
X    xlsave(fptr);
X    xlsave(expr);
X    xlsave(path);
X
X
X    /** let user choose path name **/   /* Voodoo */
X
X    fullname[0] = '\0';
X
X    /* find user path from load-path variable */
X    if ((path = xlxgetvalue(xlenter("LOAD-PATH"))) != s_unbound &&
X    stringp(path)) {
X    strcpy(fullname,getstring(path));
X    if (fullname[strlen(fullname) - 1] != '/')
X        strcat(fullname, "/");
X    }
X
X    /* incorporate filename */
X    strcat(fullname,fname);
X
X    /* default the extension */
X    if (needsextension(fname))
X    strcat(fullname,".lsp");
X
X    fname = fullname;
X
X
X    /* allocate a file node */
X    fptr = cvfile(NULL);
X
X    /* open the file */
X    if ((fp = osaopen(fname,"r")) == NULL) {
X    xlpopn(3);
X    return (FALSE);
X    }
X    setfile(fptr,fp);
X
X    /* print the information line */
X    if (vflag)
X    { sprintf(buf,"; loading \"%s\"\n",fname); stdputstr(buf); }
X
X    /* read, evaluate and possibly print each expression in the file */
X    xlbegin(&cntxt,CF_ERROR,true);
X    if (xlsetjmp(cntxt.c_jmpbuf))
X    sts = FALSE;
X    else {
X    while (xlread(fptr,&expr,FALSE)) {
X        expr = xleval(expr);
X        if (pflag)
X        stdprint(expr);
X    }
X    sts = TRUE;
X    }
X    xlend(&cntxt);
X
X    /* close the file */
X    osclose(getfile(fptr));
X    setfile(fptr,NULL);
X
X    /* restore the stack */
X    xlpopn(3);
X
X    /* return status */
X    return (sts);
X}
X
X/* xlread - read an xlisp expression */
Xint xlread(fptr,pval,rflag)
X  LVAL fptr,*pval; int rflag;
X{
X    int sts;
X
X    /* read an expression */
X    while ((sts = readone(fptr,pval)) == FALSE)
X    ;
X
X    /* return status */
X    return (sts == EOF ? FALSE : TRUE);
X}
X
X/* readone - attempt to read a single expression */
Xint readone(fptr,pval)
X  LVAL fptr,*pval;
X{
X    LVAL val,type;
X    int ch;
X
X    /* get a character and check for EOF */
X    if ((ch = xlgetc(fptr)) == EOF)
X    return (EOF);
X
X    /* handle white space */
X    if ((type = tentry(ch)) == k_wspace)
X    return (FALSE);
X
X    /* handle symbol constituents */
X    else if (type == k_const) {
X    xlungetc(fptr,ch);
X    *pval = psymbol(fptr);
X    return (TRUE);
X    }
X
X    /* handle single and multiple escapes */
X    else if (type == k_sescape || type == k_mescape) {
X    xlungetc(fptr,ch);
X    *pval = psymbol(fptr);
X    return (TRUE);
X    }
X
X    /* handle read macros */
X    else if (consp(type)) {
X    if ((val = callmacro(fptr,ch)) && consp(val)) {
X        *pval = car(val);
X        return (TRUE);
X    }
X    else
X        return (FALSE);
X    }
X
X    /* handle illegal characters */
X    else
X    xlerror("illegal character",cvfixnum((FIXTYPE)ch));
X}
X
X/* rmhash - read macro for '#' */
XLVAL rmhash()
X{
X    LVAL fptr,mch,val;
X    int escflag,ch;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* get the file and macro character */
X    fptr = xlgetfile();
X    mch = xlgachar();
X    xllastarg();
X
X    /* make the return value */
X    val = consa(NIL);
X
X    /* check the next character */
X    switch (ch = xlgetc(fptr)) {
X    case '\'':
X        rplaca(val,pquote(fptr,s_function));
X        break;
X    case '(':
X        xlungetc(fptr,ch);
X        rplaca(val,pvector(fptr));
X        break;
X    case 'b':
X    case 'B':
X        rplaca(val,pnumber(fptr,2));
X        break;
X    case 'o':
X    case 'O':
X        rplaca(val,pnumber(fptr,8));
X        break;
X    case 'x':
X    case 'X':
X            rplaca(val,pnumber(fptr,16));
X        break;
X    case 's':
X    case 'S':
X        rplaca(val,pstruct(fptr));
X        break;
X    case '\\':
X        xlungetc(fptr,ch);
X        pname(fptr,&escflag);
X        ch = buf[0];
X        if (strlen(buf) > 1) {
X            upcase(buf);
X            if (strcmp(buf,"NEWLINE") == 0)
X            ch = '\n';
X            else if (strcmp(buf,"SPACE") == 0)
X            ch = ' ';
X            else
X            xlerror("unknown character name",cvstring(buf));
X        }
X        rplaca(val,cvchar(ch));
X        break;
X    case ':':
X            rplaca(val,punintern(fptr));
X        break;
X    case '|':
X            pcomment(fptr);
X        val = NIL;
X        break;
X    default:
X        xlerror("illegal character after #",cvfixnum((FIXTYPE)ch));
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the value */
X    return (val);
X}
X
X/* rmquote - read macro for '\'' */
XLVAL rmquote()
X{
X    LVAL fptr,mch;
X
X    /* get the file and macro character */
X    fptr = xlgetfile();
X    mch = xlgachar();
X    xllastarg();
X
X    /* parse the quoted expression */
X    return (consa(pquote(fptr,s_quote)));
X}
X
X/* rmdquote - read macro for '"' */
XLVAL rmdquote()
X{
X    unsigned char buf[STRMAX+1],*p,*sptr;
X    LVAL fptr,str,newstr,mch;
X    int len,blen,ch,d2,d3;
X
X    /* protect some pointers */
X    xlsave1(str);
X
X    /* get the file and macro character */
X    fptr = xlgetfile();
X    mch = xlgachar();
X    xllastarg();
X
X    /* loop looking for a closing quote */
X    len = blen = 0; p = buf;
X    while ((ch = checkeof(fptr)) != '"') {
X
X    /* handle escaped characters */
X    switch (ch) {
X    case '\\':
X        switch (ch = checkeof(fptr)) {
X        case 't':
X            ch = '\011';
X            break;
X        case 'n':
X            ch = '\012';
X            break;
X        case 'f':
X            ch = '\014';
X            break;
X        case 'r':
X            ch = '\015';
X            break;
X        default:
X            if (ch >= '0' && ch <= '7') {
X                d2 = checkeof(fptr);
X                d3 = checkeof(fptr);
X                if (d2 < '0' || d2 > '7'
X                 || d3 < '0' || d3 > '7')
X                xlfail("invalid octal digit");
X                ch -= '0'; d2 -= '0'; d3 -= '0';
X                ch = (ch << 6) | (d2 << 3) | d3;
X            }
X            break;
X        }
X    }
X
X    /* check for buffer overflow */
X    if (blen >= STRMAX) {
X         newstr = newstring(len + STRMAX + 1);
X        sptr = getstring(newstr); *sptr = '\0';
X        if (str) strcat(sptr,getstring(str));
X        *p = '\0'; strcat(sptr,buf);
X        p = buf; blen = 0;
X        len += STRMAX;
X        str = newstr;
X    }
X
X    /* store the character */
X    *p++ = ch; ++blen;
X    }
X
X    /* append the last substring */
X    if (str == NIL || blen) {
X    newstr = newstring(len + blen + 1);
X    sptr = getstring(newstr); *sptr = '\0';
X    if (str) strcat(sptr,getstring(str));
X    *p = '\0'; strcat(sptr,buf);
X    str = newstr;
X    }
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the new string */
X    return (consa(str));
X}
X
X/* rmbquote - read macro for '`' */
XLVAL rmbquote()
X{
X    LVAL fptr,mch;
X
X    /* get the file and macro character */
X    fptr = xlgetfile();
X    mch = xlgachar();
X    xllastarg();
X
X    /* parse the quoted expression */
X    return (consa(pquote(fptr,s_bquote)));
X}
X
X/* rmcomma - read macro for ',' */
XLVAL rmcomma()
X{
X    LVAL fptr,mch,sym;
X    int ch;
X
X    /* get the file and macro character */
X    fptr = xlgetfile();
X    mch = xlgachar();
X    xllastarg();
X
X    /* check the next character */
X    if ((ch = xlgetc(fptr)) == '@')
X    sym = s_comat;
X    else {
X    xlungetc(fptr,ch);
X    sym = s_comma;
X    }
X
X    /* make the return value */
X    return (consa(pquote(fptr,sym)));
X}
X
X/* rmlpar - read macro for '(' */
XLVAL rmlpar()
X{
X    LVAL fptr,mch;
X
X    /* get the file and macro character */
X    fptr = xlgetfile();
X    mch = xlgachar();
X    xllastarg();
X
X    /* make the return value */
X    return (consa(plist(fptr)));
X}
X
X/* rmrpar - read macro for ')' */
XLVAL rmrpar()
X{
X    xlfail("misplaced right paren");
X}
X
X/* rmsemi - read macro for ';' */
XLVAL rmsemi()
X{
X    LVAL fptr,mch;
X    int ch;
X
X    /* get the file and macro character */
X    fptr = xlgetfile();
X    mch = xlgachar();
X    xllastarg();
X
X    /* skip to end of line */
X    while ((ch = xlgetc(fptr)) != EOF && ch != '\n')
X    ;
X
X    /* return nil (nothing read) */
X    return (NIL);
X}
X
X/* pcomment - parse a comment delimited by #| and |# */
XLOCAL pcomment(fptr)
X  LVAL fptr;
X{
X    int lastch,ch,n;
X
X    /* look for the matching delimiter (and handle nesting) */
X    for (n = 1, lastch = -1; n > 0 && (ch = xlgetc(fptr)) != EOF; ) {
X    if (lastch == '|' && ch == '#')
X        { --n; ch = -1; }
X    else if (lastch == '#' && ch == '|')
X        { ++n; ch = -1; }
X    lastch = ch;
X    }
X}
X
X/* pnumber - parse a number */
XLOCAL LVAL pnumber(fptr,radix)
X  LVAL fptr; int radix;
X{
X    int digit,ch;
X    long num;
X
X    for (num = 0L; (ch = xlgetc(fptr)) != EOF; ) {
X    if (islower(ch)) ch = toupper(ch);
X    if (!('0' <= ch && ch <= '9') && !('A' <= ch && ch <= 'F'))
X        break;
X    if ((digit = (ch <= '9' ? ch - '0' : ch - 'A' + 10)) >= radix)
X        break;
X    num = num * (long)radix + (long)digit;
X    }
X    xlungetc(fptr,ch);
X    return (cvfixnum((FIXTYPE)num));
X}
X
X/* plist - parse a list */
XLOCAL LVAL plist(fptr)
X  LVAL fptr;
X{
X    LVAL val,expr,lastnptr,nptr;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(val);
X    xlsave(expr);
X
X    /* keep appending nodes until a closing paren is found */
X    for (lastnptr = NIL; nextch(fptr) != ')'; )
X
X    /* get the next expression */
X    switch (readone(fptr,&expr)) {
X    case EOF:
X        badeof(fptr);
X    case TRUE:
X
X        /* check for a dotted tail */
X        if (expr == s_dot) {
X
X        /* make sure there's a node */
X        if (lastnptr == NIL)
X            xlfail("invalid dotted pair");
X
X        /* parse the expression after the dot */
X        if (!xlread(fptr,&expr,TRUE))
X            badeof(fptr);
X        rplacd(lastnptr,expr);
X
X        /* make sure its followed by a close paren */
X        if (nextch(fptr) != ')')
X            xlfail("invalid dotted pair");
X        }
X
X        /* otherwise, handle a normal list element */
X        else {
X        nptr = consa(expr);
X        if (lastnptr == NIL)
X            val = nptr;
X        else
X            rplacd(lastnptr,nptr);
X        lastnptr = nptr;
X        }
X        break;
X    }
X
X    /* skip the closing paren */
X    xlgetc(fptr);
X
X    /* restore the stack */
X    xlpopn(2);
X
X    /* return successfully */
X    return (val);
X}
X
X/* pvector - parse a vector */
XLOCAL LVAL pvector(fptr)
X  LVAL fptr;
X{
X    LVAL list,val;
X    int len,i;
X
X    /* protect some pointers */
X    xlsave1(list);
X
X    /* read the list */
X    list = readlist(fptr,&len);
X
X    /* make a vector of the appropriate length */
X    val = newvector(len);
X
X    /* copy the list into the vector */
X    for (i = 0; i < len; ++i, list = cdr(list))
X    setelement(val,i,car(list));
X
X    /* restore the stack */
X    xlpop();
X
X    /* return successfully */
X    return (val);
X}
X
X/* pstruct - parse a structure */
XLOCAL LVAL pstruct(fptr)
X  LVAL fptr;
X{
X    extern LVAL xlrdstruct();
X    LVAL list,val;
X    int len;
X
X    /* protect some pointers */
X    xlsave1(list);
X
X    /* read the list */
X    list = readlist(fptr,&len);
X
X    /* make the structure */
X    val = xlrdstruct(list);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return successfully */
X    return (val);
X}
X
X/* pquote - parse a quoted expression */
XLOCAL LVAL pquote(fptr,sym)
X  LVAL fptr,sym;
X{
X    LVAL val,p;
X
X    /* protect some pointers */
X    xlsave1(val);
X
X    /* allocate two nodes */
X    val = consa(sym);
X    rplacd(val,consa(NIL));
X
X    /* initialize the second to point to the quoted expression */
X    if (!xlread(fptr,&p,TRUE))
X    badeof(fptr);
X    rplaca(cdr(val),p);
X
X    /* restore the stack */
X    xlpop();
X
X    /* return the quoted expression */
X    return (val);
X}
X
X/* psymbol - parse a symbol name */
XLOCAL LVAL psymbol(fptr)
X  LVAL fptr;
X{
X    int escflag;
X    LVAL val;
X    pname(fptr,&escflag);
X    return (escflag || !isnumber(buf,&val) ? xlenter(buf) : val);
X}
X
X/* punintern - parse an uninterned symbol */
XLOCAL LVAL punintern(fptr)
X  LVAL fptr;
X{
X    int escflag;
X    pname(fptr,&escflag);
X    return (xlmakesym(buf));
X}
X
X/* pname - parse a symbol/package name */
XLOCAL int pname(fptr,pescflag)
X  LVAL fptr; int *pescflag;
X{
X    int mode,ch,i;
X    LVAL type;
X
X    /* initialize */
X    *pescflag = FALSE;
X    mode = NORMAL;
X    i = 0;
X
X    /* accumulate the symbol name */
X    while (mode != DONE) {
X
X    /* handle normal mode */
X    while (mode == NORMAL)
X        if ((ch = xlgetc(fptr)) == EOF)
X        mode = DONE;
X        else if ((type = tentry(ch)) == k_sescape) {
X        i = storech(buf,i,checkeof(fptr));
X        *pescflag = TRUE;
X        }
X        else if (type == k_mescape) {
X        *pescflag = TRUE;
X        mode = ESCAPE;
X        }
X        else if (type == k_const
X         ||  (consp(type) && car(type) == k_nmacro))
X        i = storech(buf,i,islower(ch) ? toupper(ch) : ch);
X        else
X        mode = DONE;
X
X    /* handle multiple escape mode */
X    while (mode == ESCAPE)
X        if ((ch = xlgetc(fptr)) == EOF)
X        badeof(fptr);
X        else if ((type = tentry(ch)) == k_sescape)
X        i = storech(buf,i,checkeof(fptr));
X        else if (type == k_mescape)
X        mode = NORMAL;
X        else
X        i = storech(buf,i,ch);
X    }
X    buf[i] = 0;
X
X    /* check for a zero length name */
X    if (i == 0)
X    xlfail("zero length name");
X
X    /* unget the last character and return it */
X    xlungetc(fptr,ch);
X    return (ch);
X}
X
X/* readlist - read a list terminated by a ')' */
XLOCAL LVAL readlist(fptr,plen)
X  LVAL fptr; int *plen;
X{
X    LVAL list,expr,lastnptr,nptr;
X    int ch;
X
X    /* protect some pointers */
X    xlstkcheck(2);
X    xlsave(list);
X    xlsave(expr);
X
X    /* get the open paren */
X    if ((ch = nextch(fptr)) != '(')
X    xlfail("expecting an open paren");
X    xlgetc(fptr);
X
X    /* keep appending nodes until a closing paren is found */
X    for (lastnptr = NIL, *plen = 0; (ch = nextch(fptr)) != ')'; ) {
X
X    /* check for end of file */
X    if (ch == EOF)
X        badeof(fptr);
X
X    /* get the next expression */
X    switch (readone(fptr,&expr)) {
X    case EOF:
X        badeof(fptr);
X    case TRUE:
X        nptr = consa(expr);
X        if (lastnptr == NIL)
X        list = nptr;
X        else
X        rplacd(lastnptr,nptr);
X        lastnptr = nptr;
X        ++(*plen);
X        break;
X    }
X    }
X
X    /* skip the closing paren */
X    xlgetc(fptr);
X
X    /* restore the stack */
X    xlpopn(2);
X
X    /* return the list */
X    return (list);
X}
X
X/* storech - store a character in the print name buffer */
XLOCAL int storech(buf,i,ch)
X  char *buf; int i,ch;
X{
X    if (i < STRMAX)
X    buf[i++] = ch;
X    return (i);
X}
X
X/* tentry - get a readtable entry */
XLVAL tentry(ch)
X  int ch;
X{
X    LVAL rtable;
X    rtable = getvalue(s_rtable);
X    if (!vectorp(rtable) || ch < 0 || ch >= getsz(rtable))
X    return (NIL);
X    return (getelement(rtable,ch));
X}
X
X/* nextch - look at the next non-blank character */
XLOCAL int nextch(fptr)
X  LVAL fptr;
X{
X    int ch;
X
X    /* return and save the next non-blank character */
X    while ((ch = xlgetc(fptr)) != EOF && isspace(ch))
X    ;
X    xlungetc(fptr,ch);
X    return (ch);
X}
X
X/* checkeof - get a character and check for end of file */
XLOCAL int checkeof(fptr)
X  LVAL fptr;
X{
X    int ch;
X
X    if ((ch = xlgetc(fptr)) == EOF)
X    badeof(fptr);
X    return (ch);
X}
X
X/* badeof - unexpected eof */
XLOCAL badeof(fptr)
X  LVAL fptr;
X{
X    xlgetc(fptr);
X    xlfail("unexpected EOF");
X}
X
X/* isnumber - check if this string is a number */
Xint isnumber(str,pval)
X  char *str; LVAL *pval;
X{
X    int dl,dr;
X    char *p;
X
X    /* initialize */
X    p = str; dl = dr = 0;
X
X    /* check for a sign */
X    if (*p == '+' || *p == '-')
X    p++;
X
X    /* check for a string of digits */
X    while (isdigit(*p))
X    p++, dl++;
X
X    /* check for a decimal point */
X    if (*p == '.') {
X    p++;
X    while (isdigit(*p))
X        p++, dr++;
X    }
X
X    /* check for an exponent */
X    if ((dl || dr) && *p == 'E') {
X    p++;
X
X    /* check for a sign */
X    if (*p == '+' || *p == '-')
X        p++;
X
X    /* check for a string of digits */
X    while (isdigit(*p))
X        p++, dr++;
X    }
X
X    /* make sure there was at least one digit and this is the end */
X    if ((dl == 0 && dr == 0) || *p)
X    return (FALSE);
X
X    /* convert the string to an integer and return successfully */
X    if (pval) {
X    if (*str == '+') ++str;
X    if (str[strlen(str)-1] == '.') str[strlen(str)-1] = 0;
X    *pval = (dr ? cvflonum(atof(str)) : cvfixnum(ICNV(str)));
X    }
X    return (TRUE);
X}
X
X/* defmacro - define a read macro */
Xdefmacro(ch,type,offset)
X  int ch; LVAL type; int offset;
X{
X    extern FUNDEF *funtab;
X    LVAL subr;
X    subr = cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset);
X    setelement(getvalue(s_rtable),ch,cons(type,subr));
X}
X
X/* callmacro - call a read macro */
XLVAL callmacro(fptr,ch)
X  LVAL fptr; int ch;
X{
X    LVAL *newfp;
X
X    /* create the new call frame */
X    newfp = xlsp;
X    pusharg(cvfixnum((FIXTYPE)(newfp - xlfp)));
X    pusharg(cdr(getelement(getvalue(s_rtable),ch)));
X    pusharg(cvfixnum((FIXTYPE)2));
X    pusharg(fptr);
X    pusharg(cvchar(ch));
X    xlfp = newfp;
X    return (xlapply(2));
X}
X
X/* upcase - translate a string to upper case */
XLOCAL upcase(str)
X  unsigned char *str;
X{
X    for (; *str != '\0'; ++str)
X    if (islower(*str))
X        *str = toupper(*str);
X}
X
X/* xlrinit - initialize the reader */
Xxlrinit()
X{
X    LVAL rtable;
X    char *p;
X    int ch;
X
X    /* create the read table */
X    rtable = newvector(256);
X    setvalue(s_rtable,rtable);
X
X    /* initialize the readtable */
X    for (p = WSPACE; ch = *p++; )
X    setelement(rtable,ch,k_wspace);
X    for (p = CONST1; ch = *p++; )
X    setelement(rtable,ch,k_const);
X    for (p = CONST2; ch = *p++; )
X    setelement(rtable,ch,k_const);
X
X    /* setup the escape characters */
X    setelement(rtable,'\\',k_sescape);
X    setelement(rtable,'|', k_mescape);
X
X    /* install the read macros */
X    defmacro('#', k_nmacro,FT_RMHASH);
X    defmacro('\'',k_tmacro,FT_RMQUOTE);
X    defmacro('"', k_tmacro,FT_RMDQUOTE);
X    defmacro('`', k_tmacro,FT_RMBQUOTE);
X    defmacro(',', k_tmacro,FT_RMCOMMA);
X    defmacro('(', k_tmacro,FT_RMLPAR);
X    defmacro(')', k_tmacro,FT_RMRPAR);
X    defmacro(';', k_tmacro,FT_RMSEMI);
X}
END_OF_FILE
if test 19982 -ne `wc -c <'src/xlisp/xcore/c/xlread.c'`; then
    echo shar: \"'src/xlisp/xcore/c/xlread.c'\" unpacked with wrong size!
fi
# end of 'src/xlisp/xcore/c/xlread.c'
fi
echo shar: End of archive 9 \(of 16\).
cp /dev/null ark9isdone
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