Compare commits
36 Commits
medley-240
...
medley-240
| Author | SHA1 | Date | |
|---|---|---|---|
|
e1989850f3 | ||
|
|
fface7d9de | ||
|
|
b41ae0cbbe | ||
|
|
548d3f1567 | ||
|
|
a85d6287ae | ||
|
|
719b4e744e | ||
|
|
387fecf475 | ||
|
433ffaf9e5 | ||
|
|
2cec465f1f | ||
|
|
ca03e7f930 | ||
|
|
3526a61be1 | ||
|
|
115ba43100 | ||
|
d2b87a7327 | ||
|
|
f03a2fb4cb | ||
|
|
244300de7b | ||
|
e9200c73c9 | ||
|
|
1ffcde195a | ||
|
|
19015712de | ||
|
|
7b0c746af2 | ||
|
|
325bc9b5da | ||
|
|
94548bd7da | ||
|
|
d1fcd6cf7e | ||
|
9e7445927c | ||
|
|
31863256c8 | ||
|
|
a8c82aa9c4 | ||
|
|
84cd0c73cb | ||
|
|
54bea56b81 | ||
|
|
65cfd1dd69 | ||
|
|
7dcc200c91 | ||
|
|
9e0fdd0283 | ||
|
|
ffe99d6bcc | ||
|
|
3e77f627a0 | ||
|
|
8d648f46b1 | ||
|
|
e7dccf76a9 | ||
|
|
ff25001814 | ||
|
|
9793e48c4e |
28
.github/workflows/buildReleaseInclDocker.yml
vendored
28
.github/workflows/buildReleaseInclDocker.yml
vendored
@@ -3,6 +3,7 @@
|
||||
#
|
||||
# Interlisp webflow to build a Medley release and push it to github.
|
||||
# And to build a multiplatform Docker image for the release and push it to Docker Hub.
|
||||
# And to kickoff a build and deploy workflow for Medley-online within the online repo.
|
||||
#
|
||||
# This workflow just calls two reuseable workflows to the two task:
|
||||
# buildLoadup.yml and buildDocker.yml
|
||||
@@ -14,12 +15,12 @@
|
||||
# ******************************************************************************
|
||||
|
||||
|
||||
name: "Build/Push Release & Docker"
|
||||
name: "Build/Push Release, Docker, OIO"
|
||||
|
||||
# Run this workflow on ...
|
||||
on:
|
||||
schedule:
|
||||
- cron: '0 9 * * 3'
|
||||
- cron: '17 9 * * 3'
|
||||
|
||||
workflow_dispatch:
|
||||
inputs:
|
||||
@@ -111,3 +112,26 @@ jobs:
|
||||
|
||||
######################################################################################
|
||||
|
||||
# Run HCFILES and push to files.interlisp.org
|
||||
do_HCFILES:
|
||||
needs: [inputs, do_release]
|
||||
uses: ./.github/workflows/doHCFILES.yml
|
||||
with:
|
||||
draft: ${{ needs.inputs.outputs.draft }}
|
||||
secrets: inherit
|
||||
|
||||
######################################################################################
|
||||
|
||||
# Kickoff workflow in online repo to build and deploy Medley docker image to oio
|
||||
do_oio:
|
||||
runs-on: ubuntu-latest
|
||||
needs: [inputs, do_docker]
|
||||
steps:
|
||||
- name: trigger-oio-buildAndDeploy
|
||||
run: |
|
||||
if [ ! "${{ needs.inputs.outputs.draft }}" = "true" ]
|
||||
then
|
||||
gh workflow run buildAndDeployMedleyDocker.yml --repo Interlisp/online --ref master
|
||||
fi
|
||||
env:
|
||||
GITHUB_TOKEN: ${{ secrets.ONLINE_TOKEN }}
|
||||
|
||||
139
.github/workflows/doHCFILES.yml
vendored
Normal file
139
.github/workflows/doHCFILES.yml
vendored
Normal file
@@ -0,0 +1,139 @@
|
||||
#*******************************************************************************
|
||||
# doHCFILES.yml
|
||||
#
|
||||
# Interlisp workflow to run HCFILES. HCFILES prints out PDF files for all of the
|
||||
# files in the Medley directory and posts them on files.interlisp.org.
|
||||
#
|
||||
# This workflow is designed to be kickjed off by the buildReleaseInclDocker
|
||||
# workflow running in the Medley repo, once the release has been completed successfully
|
||||
#
|
||||
# Copyright 2024 by Interlisp.org
|
||||
#
|
||||
# ******************************************************************************
|
||||
|
||||
name: Run HCFILES
|
||||
|
||||
# Run this workflow on ...
|
||||
on:
|
||||
workflow_dispatch:
|
||||
inputs:
|
||||
draft:
|
||||
description: "Mark this as a draft release"
|
||||
type: choice
|
||||
options:
|
||||
- 'false'
|
||||
- 'true'
|
||||
|
||||
workflow_call:
|
||||
inputs:
|
||||
draft:
|
||||
description: "Mark this as a draft release"
|
||||
required: false
|
||||
type: string
|
||||
default: 'false'
|
||||
secrets:
|
||||
OIO_SSH_KEY:
|
||||
required: true
|
||||
MU_TOKEN:
|
||||
required: true
|
||||
|
||||
defaults:
|
||||
run:
|
||||
shell: bash
|
||||
|
||||
jobs:
|
||||
|
||||
run_HCFILES:
|
||||
|
||||
runs-on: ubuntu-latest
|
||||
|
||||
steps:
|
||||
|
||||
- name: Checkout Medley repo
|
||||
uses: actions/checkout@v4
|
||||
|
||||
- name: Checkout notecards
|
||||
uses: actions/checkout@v4
|
||||
with:
|
||||
repository: ${{ github.repository_owner }}/notecards
|
||||
path: ./notecards
|
||||
|
||||
- name: Checkout loops
|
||||
uses: actions/checkout@v4
|
||||
with:
|
||||
repository: ${{ github.repository_owner }}/loops
|
||||
path: ./loops
|
||||
|
||||
- name: Checkout test
|
||||
uses: actions/checkout@v4
|
||||
with:
|
||||
repository: ${{ github.repository_owner }}/test
|
||||
path: ./test
|
||||
|
||||
- name: Cleanup .git for notecards, loops, test
|
||||
run: rm -rf ./notecards/.git ./loops/.git ./test/.git
|
||||
|
||||
- name: Download Maiko
|
||||
run: |
|
||||
gh release download --output /tmp/maiko.tgz \
|
||||
--repo ${{ github.repository_owner }}/maiko \
|
||||
--pattern '*-linux.x86_64.tgz'
|
||||
tar -xzf /tmp/maiko.tgz
|
||||
env:
|
||||
GH_TOKEN: ${{ secrets.MU_TOKEN }}
|
||||
|
||||
- name: Install vnc & ghostscript (ps2pdf)
|
||||
run: |
|
||||
sudo apt-get update
|
||||
sudo apt-get install -y tightvncserver
|
||||
sudo apt-get install -y ghostscript
|
||||
|
||||
- name: Build apps.sysout
|
||||
run: |
|
||||
Xvnc -geometry 1280x720 :0 &
|
||||
export DISPLAY=":0"
|
||||
scripts/loadup-all.sh -apps
|
||||
|
||||
- name: Run HCFILES
|
||||
run: |
|
||||
export DISPLAY=":0"
|
||||
scripts/do_hcfiles.sh
|
||||
|
||||
- name: Push Medley files (including created pdf files) to files.interlisp.org
|
||||
run: |
|
||||
# create a tar file of all of the directories to be pushed
|
||||
tarfile=/tmp/source-$$.tgz
|
||||
tar -c -z -f ${tarfile} --exclude=.git .
|
||||
# set up ssh identity
|
||||
eval $(ssh-agent)
|
||||
ssh-add - <<< "${SSH_KEY}"
|
||||
# set destination directory on files.interlisp.org
|
||||
if [ "${{ inputs.draft }}" = "true" ]
|
||||
then
|
||||
dest=/srv/oio/files/development/medley
|
||||
else
|
||||
dest=/srv/oio/files/production/medley
|
||||
fi
|
||||
# Push tar file up to files.interlisp.org
|
||||
batchfile=/tmp/batch-$$
|
||||
echo "-put ${tarfile} ${dest}.tgz" > ${batchfile}
|
||||
sftp -o StrictHostKeyChecking=no -b ${batchfile} ubuntu@files.interlisp.org
|
||||
# now tar is up, untar it and juggle backups
|
||||
scriptfile=/tmp/script-$$
|
||||
# create script file to do the work
|
||||
cat > ${scriptfile} <<EOF
|
||||
rm -rf ${dest}.new
|
||||
mkdir -p ${dest}.new
|
||||
tar -C ${dest}.new -x -z -f ${dest}.tgz
|
||||
rm -f ${dest}.tgz
|
||||
rm -rf ${dest}.oldold
|
||||
if [ -e ${dest}.old ]; then mv ${dest}.old ${dest}.oldold; fi
|
||||
if [ -e ${dest} ]; then mv ${dest} ${dest}.old; fi
|
||||
mv ${dest}.new ${dest}
|
||||
EOF
|
||||
# execute the script file via ssh
|
||||
ssh -aTxo BatchMode=yes ubuntu@files.interlisp.org /bin/sh -s < ${scriptfile}
|
||||
env:
|
||||
SSH_KEY: ${{ secrets.OIO_SSH_KEY }}
|
||||
|
||||
|
||||
5
.gitignore
vendored
5
.gitignore
vendored
@@ -14,7 +14,10 @@ maiko/
|
||||
# because they will get regenerated when you rebuild.
|
||||
# MEDLEY-UTILS HCFILES regenerates
|
||||
|
||||
*.pdf
|
||||
# do not ignore .pdf files after all... rather, [new workflow](scripts/make-gh-pages.md) stores it in the src repository gh-pages branch.
|
||||
|
||||
# *.pdf
|
||||
# index.html
|
||||
|
||||
|
||||
# all loadup files
|
||||
|
||||
313
doctools/IMTEDIT
313
doctools/IMTEDIT
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 6-Mar-2024 21:18:02" {WMEDLEY}<doctools>IMTEDIT.;4 116622
|
||||
(FILECREATED "12-Apr-2024 19:58:59" {WMEDLEY}<doctools>IMTEDIT.;5 117369
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS TRANSLATE.DUMPOUT MAKE.IM.DOCUMENT)
|
||||
:CHANGES-TO (FNS MAKE.IM.DOCUMENT)
|
||||
|
||||
:PREVIOUS-DATE "20-Jul-2022 15:10:53" {WMEDLEY}<doctools>IMTEDIT.;2)
|
||||
:PREVIOUS-DATE " 6-Mar-2024 21:18:02" {WMEDLEY}<doctools>IMTEDIT.;4)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT IMTEDITCOMS)
|
||||
@@ -15,16 +15,17 @@
|
||||
((FNS IM.TEDIT DUMP DUMP.HEADERS.FOOTERS DUMP.HRULE CHANGE.FONT IM.BOUT.IMAGEOBJ
|
||||
IM.TEDIT.DUMP.COMMANDS IM.TEDIT.DUMP.FOOTNOTES IM.TEDIT.DUMP.PARA INDEXX.PARSE.TYPE
|
||||
FORMAT.DEF FORMAT.LISPWORD MAKE.IM.DOCUMENT PRINT.NOTE SEND.INFO)
|
||||
(COMS (* fns for drawing vrules to the left of definition text -- an unused, never-fully
|
||||
debuged feature)
|
||||
(COMS (* ;
|
||||
"fns for drawing vrules to the left of definition text -- an unused, never-fully debuged feature")
|
||||
(FNS IM.VRULE.DISPLAYFN CREATE.VRULE.OBJECT PRINT.VRULES.ON.PAGE)
|
||||
(VARS (IM.VRULE.STATE.LIST))
|
||||
(INITVARS (IM.VRULE.OBJECT.IMAGEFNS NIL)
|
||||
(IM.PRINT.VRULE.FLG NIL)))
|
||||
(COMS (* fns for printing page numbers)
|
||||
(COMS (* ; "fns for printing page numbers")
|
||||
(FNS IM.FOLIO.DISPLAYFN IM.FOLIO.SIZEFN CREATE.FOLIO.OBJECT GET.FOLIO.STRING)
|
||||
(INITVARS (IM.FOLIO.OBJECT.IMAGEFNS NIL)))
|
||||
(COMS (* TOPROG functions, used to define the translating actions of IM text objects.)
|
||||
(COMS (* ;
|
||||
"TOPROG functions, used to define the translating actions of IM text objects.")
|
||||
(FNS ARG#TOPROG BIGLISPCODE#TOPROG BRACKET#TOPROG CHAPTER#TOPROG COMMENT#TOPROG
|
||||
DEF#TOPROG FIGURE#TOPROG FN#TOPROG FNDEF#TOPROG FOOT#TOPROG INCLUDE#TOPROG
|
||||
INDEX#TOPROG INDEXX#TOPROG IT#TOPROG LBRACKET#TOPROG LISP#TOPROG LISPCODE#TOPROG
|
||||
@@ -54,104 +55,112 @@
|
||||
(IM.TEXT.FONT '(FAMILY MODERN FACE MRR SIZE 10))
|
||||
(IM.HEADER.FOOTER.FONT '(FAMILY MODERN FACE MRR SIZE 8))
|
||||
(IM.XEROX.LOGO.FONT '(FAMILY MODERN FACE BRR SIZE 30]
|
||||
(COMS (* the following variables specify all of the lengths used for possitioning IM text,
|
||||
headers, etc. on the page. All of these are measured with respect to the page
|
||||
*margins* <the region on the page defined by the Tedit margin parameters> or with
|
||||
respect to the page *edges* <the edges of the physical page>.)
|
||||
(* Note%: The formatting and printing does not always position the image on the page
|
||||
exactly as specified. It will probably be necessary to adjust any variables based on
|
||||
the page edges until they come out correctly on your printer.)
|
||||
(* indentation of 1st line of definitian header, measured in points from left page
|
||||
margin. Also used for indentation of hrule under defn header.)
|
||||
(COMS
|
||||
(* ;; "the following variables specify all of the lengths used for possitioning IM text, headers, etc. on the page. All of these are measured with respect to the page *margins* <the region on the page defined by the Tedit margin parameters> or with respect to the page *edges* <the edges of the physical page>.")
|
||||
|
||||
|
||||
(* ;; "Note: The formatting and printing does not always position the image on the page exactly as specified. It will probably be necessary to adjust any variables based on the page edges until they come out correctly on your printer.")
|
||||
|
||||
|
||||
(* ;; "indentation of 1st line of definitian header, measured in points from left page margin. Also used for indentation of hrule under defn header.")
|
||||
|
||||
(INITVARS (IM.DEF.TITLE.1STLEFTMARGIN 75))
|
||||
(* indentation of 2nd and other overflow lines of definition header, measured in points
|
||||
from left page margin.)
|
||||
|
||||
(* ;; "indentation of 2nd and other overflow lines of definition header, measured in points from left page margin.")
|
||||
|
||||
(INITVARS (IM.DEF.TITLE.LEFTMARGIN 204))
|
||||
(* indentation of vertical rule to the left of definition text, measured in points from
|
||||
left page margin. This is a never-used, never-debugged feature.)
|
||||
|
||||
(* ;; "indentation of vertical rule to the left of definition text, measured in points from left page margin. This is a never-used, never-debugged feature.")
|
||||
|
||||
(INITVARS (IM.VRULE.X 194))
|
||||
(* y-pos of top-left corner of top text line, measured in points from bottom page edge.
|
||||
)
|
||||
(* ;
|
||||
"y-pos of top-left corner of top text line, measured in points from bottom page edge.")
|
||||
(INITVARS (IM.TEXT.TOPMARGIN 738))
|
||||
(* y-pos of bottom-left corner of bottom text line, measured in points from bottom page
|
||||
edge.)
|
||||
(* ;
|
||||
"y-pos of bottom-left corner of bottom text line, measured in points from bottom page edge.")
|
||||
(INITVARS (IM.TEXT.BOTTOMMARGIN 54))
|
||||
(* x-pos of left edge of text, measured in points from the left page margin.)
|
||||
(* ;
|
||||
"x-pos of left edge of text, measured in points from the left page margin.")
|
||||
(INITVARS (IM.TEXT.LEFTMARGIN 204))
|
||||
(* x-pos of right edge of text, measured in points from the left page margin.)
|
||||
(* ;
|
||||
"x-pos of right edge of text, measured in points from the left page margin.")
|
||||
(INITVARS (IM.TEXT.RIGHTMARGIN 504))
|
||||
(* X-pos and Y-pos of the lower-left corner of the
|
||||
"[This page intentionally left blank]" message printed on blank pages, measured in
|
||||
points from the left and bottom page edges.)
|
||||
|
||||
(* ;; "X-pos and Y-pos of the lower-left corner of the '[This page intentionally left blank]' message printed on blank pages, measured in points from the left and bottom page edges.")
|
||||
|
||||
(INITVARS (IM.BLANKPAGE.SPECIALX 258)
|
||||
(IM.BLANKPAGE.SPECIALY 400))
|
||||
(* In the table of contents, indentation of first and second-level subsection headers,
|
||||
measured in points from the left page margin.)
|
||||
|
||||
(* ;; "In the table of contents, indentation of first and second-level subsection headers, measured in points from the left page margin.")
|
||||
|
||||
(INITVARS (IM.TOC.SUBSEC.ONE.LEFTMARGIN 120)
|
||||
(IM.TOC.SUBSEC.TWO.LEFTMARGIN 216))
|
||||
(* in the index, the indentation of the first line and remaining lines of a top-level
|
||||
entry, of a subentry, and of a subsubentry, measured in points from the left page
|
||||
margin <for the left column>.)
|
||||
|
||||
(* ;; "in the index, the indentation of the first line and remaining lines of a top-level entry, of a subentry, and of a subsubentry, measured in points from the left page margin <for the left column>.")
|
||||
|
||||
(INITVARS (IM.INDEX.1STLEFTMARGIN 0)
|
||||
(IM.INDEX.LEFTMARGIN 75)
|
||||
(IM.INDEX.SUB.1STLEFTMARGIN 25)
|
||||
(IM.INDEX.SUB.LEFTMARGIN 75)
|
||||
(IM.INDEX.SUBSUB.1STLEFTMARGIN 50)
|
||||
(IM.INDEX.SUBSUB.LEFTMARGIN 75))
|
||||
(* on the title page, the y-pos of the lower-left corner of the first line in the title
|
||||
<and of the XEROX logo>, measured in points from the bottom page margin. The X-pos
|
||||
is always 0 for the XEROX logo, and the normal text indentation for the title.)
|
||||
|
||||
(* ;; "on the title page, the y-pos of the lower-left corner of the first line in the title <and of the XEROX logo>, measured in points from the bottom page margin. The X-pos is always 0 for the XEROX logo, and the normal text indentation for the title.")
|
||||
|
||||
(INITVARS (IM.TITLEPAGE.TITLE.Y 258))
|
||||
(* on the title page, the y-pos of the lower-left corner of the first line in the
|
||||
document number, measured in points from the bottom page margin. The Y-pos is always
|
||||
the normal text indentation.)
|
||||
|
||||
(* ;; "on the title page, the y-pos of the lower-left corner of the first line in the document number, measured in points from the bottom page margin. The Y-pos is always the normal text indentation.")
|
||||
|
||||
(INITVARS (IM.TITLEPAGE.DOCNUMBER.Y 45))
|
||||
(* Tedit tab setting used for subsection heading text. "(40 . LEFT)" determines the
|
||||
indentation of the title after the subsec number, measured in points from the left
|
||||
page margin. "18" is the tab used if the subsec number is wider than 40 pts.)
|
||||
|
||||
(* ;; "Tedit tab setting used for subsection heading text. '(40 . LEFT)' determines the indentation of the title after the subsec number, measured in points from the left page margin. '18' is the tab used if the subsec number is wider than 40 pts.")
|
||||
|
||||
[INITVARS (IM.SUBSEC.TITLE.TABS '(18 (40 . LEFT]
|
||||
(* Tedit tab setting used for chapter titles, headers, and footers to right-justify
|
||||
text. "(504 . RIGHT)" specifies a right tab at the right-hand edge of the text,
|
||||
measured in points from the left page margin.)
|
||||
|
||||
(* ;; "Tedit tab setting used for chapter titles, headers, and footers to right-justify text. '(504 . RIGHT)' specifies a right tab at the right-hand edge of the text, measured in points from the left page margin.")
|
||||
|
||||
[INITVARS (IM.RIGHT.MARGIN.TABS '(0 (504 . RIGHT]
|
||||
(* Tedit tab setting used for labeled lists, numbered lists, bullet-ed lists.
|
||||
"(186 . RIGHT)" right-justifies the label on the left of the center space.
|
||||
"(204 . LEFT)" starts the first line of the list item with the same indentation as
|
||||
normal text. Both measurements are measured in points from the left page margin.)
|
||||
|
||||
(* ;; "Tedit tab setting used for labeled lists, numbered lists, bullet-ed lists. '(186 . RIGHT)' right-justifies the label on the left of the center space. '(204 . LEFT)' starts the first line of the list item with the same indentation as normal text. Both measurements are measured in points from the left page margin.")
|
||||
|
||||
[INITVARS (IM.LABELED.LIST.TABS '(18 (186 . RIGHT)
|
||||
(204 . LEFT]
|
||||
(* left, right, top, and bottom margins of the "page region" %, measured in points from
|
||||
the four edges of the page.)
|
||||
|
||||
(* ;; "left, right, top, and bottom margins of the 'page region' , measured in points from the four edges of the page.")
|
||||
|
||||
(INITVARS (IM.PAGE.LEFTMARGIN 58)
|
||||
(IM.PAGE.RIGHTMARGIN 54)
|
||||
(IM.PAGE.TOPMARGIN 54)
|
||||
(IM.PAGE.BOTTOMMARGIN 54))
|
||||
(* top margin of the page region for the first page of a chapter <where the first
|
||||
paragraph is the chapter title>, measured in points from the top page edge.)
|
||||
|
||||
(* ;; "top margin of the page region for the first page of a chapter <where the first paragraph is the chapter title>, measured in points from the top page edge.")
|
||||
|
||||
(INITVARS (IM.PAGE.FIRST.TOPMARGIN 12))
|
||||
(* top margin of the page region for the first page of the index, measured in points
|
||||
from the top page edge. Note that in the case of the index, because it uses two
|
||||
columns, the index title is implemented as a Tedit header, instead of as the first
|
||||
paragraph of the document.)
|
||||
|
||||
(* ;; "top margin of the page region for the first page of the index, measured in points from the top page edge. Note that in the case of the index, because it uses two columns, the index title is implemented as a Tedit header, instead of as the first paragraph of the document.")
|
||||
|
||||
(INITVARS (IM.INDEX.PAGE.FIRST.TOPMARGIN 144))
|
||||
(* y-pos of lower-left corner of footer text, measured in points from the bottom page
|
||||
edge.)
|
||||
(* ;
|
||||
"y-pos of lower-left corner of footer text, measured in points from the bottom page edge.")
|
||||
(INITVARS (IM.FOOTER.Y 22))
|
||||
(* y-pos of the footer hrule, measured in points from the bottom page edge.)
|
||||
(* ;
|
||||
"y-pos of the footer hrule, measured in points from the bottom page edge.")
|
||||
(INITVARS (IM.FOOTER.RULE.Y 30))
|
||||
(* y-pos of lower-left corner of header text, measured in points from the bottom page
|
||||
edge.)
|
||||
(* ;
|
||||
"y-pos of lower-left corner of header text, measured in points from the bottom page edge.")
|
||||
(INITVARS (IM.HEADER.Y 761))
|
||||
(* y-pos of the header hrule, measured in points from the bottom page edge.)
|
||||
(* ;
|
||||
"y-pos of the header hrule, measured in points from the bottom page edge.")
|
||||
(INITVARS (IM.HEADER.RULE.Y 757))
|
||||
(* y-pos of lower-left corner of bottom draft message, measured in points from the
|
||||
bottom page edge.)
|
||||
(* ;
|
||||
"y-pos of lower-left corner of bottom draft message, measured in points from the bottom page edge.")
|
||||
(INITVARS (IM.DRAFT.MESSAGE.BOTTOM.Y 5))
|
||||
(* y-pos of lower-left corner of top draft message, measured in points from the bottom
|
||||
page edge.)
|
||||
(* ;
|
||||
"y-pos of lower-left corner of top draft message, measured in points from the bottom page edge.")
|
||||
(INITVARS (IM.DRAFT.MESSAGE.TOP.Y 775))
|
||||
(* x-pos of lower-left corner of both top and bottom draft messages, measured in points
|
||||
from the left page edge.)
|
||||
|
||||
(* ;; "x-pos of lower-left corner of both top and bottom draft messages, measured in points from the left page edge.")
|
||||
|
||||
(INITVARS (IM.DRAFT.MESSAGE.X 200)))
|
||||
(FILES TEDIT IMTRAN HRULE IMINDEX)
|
||||
(FNS TRANSLATE.DUMPOUT TRANSLATE.SAVE.DUMPOUT)
|
||||
@@ -491,6 +500,8 @@
|
||||
(MAKE.IM.DOCUMENT
|
||||
[LAMBDA (FORM OUTFILE.FLG PAGE.LAYOUT OUTPUT.MESSAGE DEFAULT.PARALOOKS PTRFILENAME)
|
||||
|
||||
(* ;; "Edited 12-Apr-2024 19:58 by rmk")
|
||||
|
||||
(* ;; "Edited 6-Mar-2024 21:17 by rmk: Fixed backquote commas. Also put IM.INDEX.CLOSEF calls in TEXTPROPs so advice in IMINDEX can be eliminated.")
|
||||
|
||||
(* ;; "Edited 20-Jul-2022 15:10 by rmk")
|
||||
@@ -506,9 +517,7 @@
|
||||
|
||||
(* ;;; "PTRFILENAME is the name to be used if an index pointer file is generated during hardcopy <by printing index objects>")
|
||||
|
||||
(PROG ([IM.OUTFILE (OPENTEXTSTREAM NIL NIL NIL NIL `(IM.INDEX.PTRFILENAME ,PTRFILENAME
|
||||
AFTERHARDCOPYFN (FUNCTION
|
||||
IM.INDEX.INIT]
|
||||
(PROG ([IM.OUTFILE (OPENTEXTSTREAM NIL NIL NIL NIL `(IM.INDEX.PTRFILENAME ,PTRFILENAME]
|
||||
(FONT.STACK (CONS))
|
||||
(IM.TEDIT.LAST.PARA.BEGIN 1)
|
||||
(IM.TEDIT.LAST.FONT.BEGIN 1)
|
||||
@@ -650,7 +659,8 @@
|
||||
|
||||
|
||||
|
||||
(* fns for drawing vrules to the left of definition text -- an unused, never-fully debuged feature)
|
||||
(* ; "fns for drawing vrules to the left of definition text -- an unused, never-fully debuged feature"
|
||||
)
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
@@ -735,7 +745,7 @@
|
||||
|
||||
|
||||
|
||||
(* fns for printing page numbers)
|
||||
(* ; "fns for printing page numbers")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
@@ -831,7 +841,7 @@
|
||||
|
||||
|
||||
|
||||
(* TOPROG functions, used to define the translating actions of IM text objects.)
|
||||
(* ; "TOPROG functions, used to define the translating actions of IM text objects.")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
@@ -2062,75 +2072,78 @@
|
||||
|
||||
|
||||
|
||||
(* the following variables specify all of the lengths used for possitioning IM text, headers, etc. on
|
||||
the page. All of these are measured with respect to the page *margins* <the region on the page defined
|
||||
by the Tedit margin parameters> or with respect to the page *edges* <the edges of the physical page>.
|
||||
(* ;;
|
||||
"the following variables specify all of the lengths used for possitioning IM text, headers, etc. on the page. All of these are measured with respect to the page *margins* <the region on the page defined by the Tedit margin parameters> or with respect to the page *edges* <the edges of the physical page>."
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
(* Note%: The formatting and printing does not always position the image on the page exactly as
|
||||
specified. It will probably be necessary to adjust any variables based on the page edges until they
|
||||
come out correctly on your printer.)
|
||||
(* ;;
|
||||
"Note: The formatting and printing does not always position the image on the page exactly as specified. It will probably be necessary to adjust any variables based on the page edges until they come out correctly on your printer."
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
(* indentation of 1st line of definitian header, measured in points from left page margin. Also used
|
||||
for indentation of hrule under defn header.)
|
||||
(* ;;
|
||||
"indentation of 1st line of definitian header, measured in points from left page margin. Also used for indentation of hrule under defn header."
|
||||
)
|
||||
|
||||
|
||||
(RPAQ? IM.DEF.TITLE.1STLEFTMARGIN 75)
|
||||
|
||||
|
||||
|
||||
(* indentation of 2nd and other overflow lines of definition header, measured in points from left page
|
||||
margin.)
|
||||
(* ;;
|
||||
"indentation of 2nd and other overflow lines of definition header, measured in points from left page margin."
|
||||
)
|
||||
|
||||
|
||||
(RPAQ? IM.DEF.TITLE.LEFTMARGIN 204)
|
||||
|
||||
|
||||
|
||||
(* indentation of vertical rule to the left of definition text, measured in points from left page
|
||||
margin. This is a never-used, never-debugged feature.)
|
||||
(* ;;
|
||||
"indentation of vertical rule to the left of definition text, measured in points from left page margin. This is a never-used, never-debugged feature."
|
||||
)
|
||||
|
||||
|
||||
(RPAQ? IM.VRULE.X 194)
|
||||
|
||||
|
||||
|
||||
(* y-pos of top-left corner of top text line, measured in points from bottom page edge.)
|
||||
(* ; "y-pos of top-left corner of top text line, measured in points from bottom page edge.")
|
||||
|
||||
|
||||
(RPAQ? IM.TEXT.TOPMARGIN 738)
|
||||
|
||||
|
||||
|
||||
(* y-pos of bottom-left corner of bottom text line, measured in points from bottom page edge.)
|
||||
(* ; "y-pos of bottom-left corner of bottom text line, measured in points from bottom page edge.")
|
||||
|
||||
|
||||
(RPAQ? IM.TEXT.BOTTOMMARGIN 54)
|
||||
|
||||
|
||||
|
||||
(* x-pos of left edge of text, measured in points from the left page margin.)
|
||||
(* ; "x-pos of left edge of text, measured in points from the left page margin.")
|
||||
|
||||
|
||||
(RPAQ? IM.TEXT.LEFTMARGIN 204)
|
||||
|
||||
|
||||
|
||||
(* x-pos of right edge of text, measured in points from the left page margin.)
|
||||
(* ; "x-pos of right edge of text, measured in points from the left page margin.")
|
||||
|
||||
|
||||
(RPAQ? IM.TEXT.RIGHTMARGIN 504)
|
||||
|
||||
|
||||
|
||||
(* X-pos and Y-pos of the lower-left corner of the "[This page intentionally left blank]" message
|
||||
printed on blank pages, measured in points from the left and bottom page edges.)
|
||||
(* ;;
|
||||
"X-pos and Y-pos of the lower-left corner of the '[This page intentionally left blank]' message printed on blank pages, measured in points from the left and bottom page edges."
|
||||
)
|
||||
|
||||
|
||||
(RPAQ? IM.BLANKPAGE.SPECIALX 258)
|
||||
@@ -2139,8 +2152,9 @@ printed on blank pages, measured in points from the left and bottom page edges.)
|
||||
|
||||
|
||||
|
||||
(* In the table of contents, indentation of first and second-level subsection headers, measured in
|
||||
points from the left page margin.)
|
||||
(* ;;
|
||||
"In the table of contents, indentation of first and second-level subsection headers, measured in points from the left page margin."
|
||||
)
|
||||
|
||||
|
||||
(RPAQ? IM.TOC.SUBSEC.ONE.LEFTMARGIN 120)
|
||||
@@ -2149,8 +2163,9 @@ points from the left page margin.)
|
||||
|
||||
|
||||
|
||||
(* in the index, the indentation of the first line and remaining lines of a top-level entry, of a
|
||||
subentry, and of a subsubentry, measured in points from the left page margin <for the left column>.)
|
||||
(* ;;
|
||||
"in the index, the indentation of the first line and remaining lines of a top-level entry, of a subentry, and of a subsubentry, measured in points from the left page margin <for the left column>."
|
||||
)
|
||||
|
||||
|
||||
(RPAQ? IM.INDEX.1STLEFTMARGIN 0)
|
||||
@@ -2167,45 +2182,45 @@ subentry, and of a subsubentry, measured in points from the left page margin <fo
|
||||
|
||||
|
||||
|
||||
(* on the title page, the y-pos of the lower-left corner of the first line in the title <and of the
|
||||
XEROX logo>, measured in points from the bottom page margin. The X-pos is always 0 for the XEROX logo,
|
||||
and the normal text indentation for the title.)
|
||||
(* ;;
|
||||
"on the title page, the y-pos of the lower-left corner of the first line in the title <and of the XEROX logo>, measured in points from the bottom page margin. The X-pos is always 0 for the XEROX logo, and the normal text indentation for the title."
|
||||
)
|
||||
|
||||
|
||||
(RPAQ? IM.TITLEPAGE.TITLE.Y 258)
|
||||
|
||||
|
||||
|
||||
(* on the title page, the y-pos of the lower-left corner of the first line in the document number,
|
||||
measured in points from the bottom page margin. The Y-pos is always the normal text indentation.)
|
||||
(* ;;
|
||||
"on the title page, the y-pos of the lower-left corner of the first line in the document number, measured in points from the bottom page margin. The Y-pos is always the normal text indentation."
|
||||
)
|
||||
|
||||
|
||||
(RPAQ? IM.TITLEPAGE.DOCNUMBER.Y 45)
|
||||
|
||||
|
||||
|
||||
(* Tedit tab setting used for subsection heading text. "(40 . LEFT)" determines the indentation of the
|
||||
title after the subsec number, measured in points from the left page margin. "18" is the tab used if
|
||||
the subsec number is wider than 40 pts.)
|
||||
(* ;;
|
||||
"Tedit tab setting used for subsection heading text. '(40 . LEFT)' determines the indentation of the title after the subsec number, measured in points from the left page margin. '18' is the tab used if the subsec number is wider than 40 pts."
|
||||
)
|
||||
|
||||
|
||||
(RPAQ? IM.SUBSEC.TITLE.TABS '(18 (40 . LEFT)))
|
||||
|
||||
|
||||
|
||||
(* Tedit tab setting used for chapter titles, headers, and footers to right-justify text.
|
||||
"(504 . RIGHT)" specifies a right tab at the right-hand edge of the text, measured in points from the
|
||||
left page margin.)
|
||||
(* ;;
|
||||
"Tedit tab setting used for chapter titles, headers, and footers to right-justify text. '(504 . RIGHT)' specifies a right tab at the right-hand edge of the text, measured in points from the left page margin."
|
||||
)
|
||||
|
||||
|
||||
(RPAQ? IM.RIGHT.MARGIN.TABS '(0 (504 . RIGHT)))
|
||||
|
||||
|
||||
|
||||
(* Tedit tab setting used for labeled lists, numbered lists, bullet-ed lists. "(186 . RIGHT)"
|
||||
right-justifies the label on the left of the center space. "(204 . LEFT)" starts the first line of the
|
||||
list item with the same indentation as normal text. Both measurements are measured in points from the
|
||||
left page margin.)
|
||||
(* ;;
|
||||
"Tedit tab setting used for labeled lists, numbered lists, bullet-ed lists. '(186 . RIGHT)' right-justifies the label on the left of the center space. '(204 . LEFT)' starts the first line of the list item with the same indentation as normal text. Both measurements are measured in points from the left page margin."
|
||||
)
|
||||
|
||||
|
||||
(RPAQ? IM.LABELED.LIST.TABS '(18 (186 . RIGHT)
|
||||
@@ -2213,8 +2228,9 @@ right-justifies the label on the left of the center space. "(204 . LEFT)" starts
|
||||
|
||||
|
||||
|
||||
(* left, right, top, and bottom margins of the "page region" %, measured in points from the four edges
|
||||
of the page.)
|
||||
(* ;;
|
||||
"left, right, top, and bottom margins of the 'page region' , measured in points from the four edges of the page."
|
||||
)
|
||||
|
||||
|
||||
(RPAQ? IM.PAGE.LEFTMARGIN 58)
|
||||
@@ -2227,67 +2243,70 @@ right-justifies the label on the left of the center space. "(204 . LEFT)" starts
|
||||
|
||||
|
||||
|
||||
(* top margin of the page region for the first page of a chapter <where the first paragraph is the
|
||||
chapter title>, measured in points from the top page edge.)
|
||||
(* ;;
|
||||
"top margin of the page region for the first page of a chapter <where the first paragraph is the chapter title>, measured in points from the top page edge."
|
||||
)
|
||||
|
||||
|
||||
(RPAQ? IM.PAGE.FIRST.TOPMARGIN 12)
|
||||
|
||||
|
||||
|
||||
(* top margin of the page region for the first page of the index, measured in points from the top page
|
||||
edge. Note that in the case of the index, because it uses two columns, the index title is implemented
|
||||
as a Tedit header, instead of as the first paragraph of the document.)
|
||||
(* ;;
|
||||
"top margin of the page region for the first page of the index, measured in points from the top page edge. Note that in the case of the index, because it uses two columns, the index title is implemented as a Tedit header, instead of as the first paragraph of the document."
|
||||
)
|
||||
|
||||
|
||||
(RPAQ? IM.INDEX.PAGE.FIRST.TOPMARGIN 144)
|
||||
|
||||
|
||||
|
||||
(* y-pos of lower-left corner of footer text, measured in points from the bottom page edge.)
|
||||
(* ; "y-pos of lower-left corner of footer text, measured in points from the bottom page edge.")
|
||||
|
||||
|
||||
(RPAQ? IM.FOOTER.Y 22)
|
||||
|
||||
|
||||
|
||||
(* y-pos of the footer hrule, measured in points from the bottom page edge.)
|
||||
(* ; "y-pos of the footer hrule, measured in points from the bottom page edge.")
|
||||
|
||||
|
||||
(RPAQ? IM.FOOTER.RULE.Y 30)
|
||||
|
||||
|
||||
|
||||
(* y-pos of lower-left corner of header text, measured in points from the bottom page edge.)
|
||||
(* ; "y-pos of lower-left corner of header text, measured in points from the bottom page edge.")
|
||||
|
||||
|
||||
(RPAQ? IM.HEADER.Y 761)
|
||||
|
||||
|
||||
|
||||
(* y-pos of the header hrule, measured in points from the bottom page edge.)
|
||||
(* ; "y-pos of the header hrule, measured in points from the bottom page edge.")
|
||||
|
||||
|
||||
(RPAQ? IM.HEADER.RULE.Y 757)
|
||||
|
||||
|
||||
|
||||
(* y-pos of lower-left corner of bottom draft message, measured in points from the bottom page edge.)
|
||||
(* ;
|
||||
"y-pos of lower-left corner of bottom draft message, measured in points from the bottom page edge.")
|
||||
|
||||
|
||||
(RPAQ? IM.DRAFT.MESSAGE.BOTTOM.Y 5)
|
||||
|
||||
|
||||
|
||||
(* y-pos of lower-left corner of top draft message, measured in points from the bottom page edge.)
|
||||
(* ; "y-pos of lower-left corner of top draft message, measured in points from the bottom page edge.")
|
||||
|
||||
|
||||
(RPAQ? IM.DRAFT.MESSAGE.TOP.Y 775)
|
||||
|
||||
|
||||
|
||||
(* x-pos of lower-left corner of both top and bottom draft messages, measured in points from the left
|
||||
page edge.)
|
||||
(* ;;
|
||||
"x-pos of lower-left corner of both top and bottom draft messages, measured in points from the left page edge."
|
||||
)
|
||||
|
||||
|
||||
(RPAQ? IM.DRAFT.MESSAGE.X 200)
|
||||
@@ -2388,23 +2407,23 @@ page edge.)
|
||||
(PUTPROPS SAVE.DUMPOUT MACRO (X (TRANSLATE.SAVE.DUMPOUT X)))
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (10668 38115 (IM.TEDIT 10678 . 12359) (DUMP 12361 . 14656) (DUMP.HEADERS.FOOTERS 14658
|
||||
. 17024) (DUMP.HRULE 17026 . 18177) (CHANGE.FONT 18179 . 19373) (IM.BOUT.IMAGEOBJ 19375 . 19698) (
|
||||
IM.TEDIT.DUMP.COMMANDS 19700 . 23253) (IM.TEDIT.DUMP.FOOTNOTES 23255 . 23696) (IM.TEDIT.DUMP.PARA
|
||||
23698 . 24472) (INDEXX.PARSE.TYPE 24474 . 25769) (FORMAT.DEF 25771 . 27902) (FORMAT.LISPWORD 27904 .
|
||||
28055) (MAKE.IM.DOCUMENT 28057 . 36970) (PRINT.NOTE 36972 . 37186) (SEND.INFO 37188 . 38113)) (38224
|
||||
42242 (IM.VRULE.DISPLAYFN 38234 . 38558) (CREATE.VRULE.OBJECT 38560 . 40340) (PRINT.VRULES.ON.PAGE
|
||||
40342 . 42240)) (42400 47155 (IM.FOLIO.DISPLAYFN 42410 . 43088) (IM.FOLIO.SIZEFN 43090 . 43939) (
|
||||
CREATE.FOLIO.OBJECT 43941 . 45487) (GET.FOLIO.STRING 45489 . 47153)) (47287 93527 (ARG#TOPROG 47297 .
|
||||
47436) (BIGLISPCODE#TOPROG 47438 . 48674) (BRACKET#TOPROG 48676 . 48840) (CHAPTER#TOPROG 48842 . 51523
|
||||
) (COMMENT#TOPROG 51525 . 52077) (DEF#TOPROG 52079 . 55414) (FIGURE#TOPROG 55416 . 56760) (FN#TOPROG
|
||||
56762 . 57159) (FNDEF#TOPROG 57161 . 61053) (FOOT#TOPROG 61055 . 61596) (INCLUDE#TOPROG 61598 . 61913)
|
||||
(INDEX#TOPROG 61915 . 63005) (INDEXX#TOPROG 63007 . 65088) (IT#TOPROG 65090 . 65231) (LBRACKET#TOPROG
|
||||
65233 . 65387) (LISP#TOPROG 65389 . 65530) (LISPCODE#TOPROG 65532 . 66651) (LISPWORD#TOPROG 66653 .
|
||||
67393) (LIST#TOPROG 67395 . 71817) (MACDEF#TOPROG 71819 . 72997) (NOTE#TOPROG 72999 . 73679) (
|
||||
PRINT.SPECIAL.CHARS#TOPROG 73681 . 74658) (PROPDEF#TOPROG 74660 . 74937) (RBRACKET#TOPROG 74939 .
|
||||
75093) (REF#TOPROG 75095 . 82934) (RM#TOPROG 82936 . 83074) (SUB#TOPROG 83076 . 83224) (SUBSEC#TOPROG
|
||||
83226 . 87729) (SUPER#TOPROG 87731 . 87885) (TABLE#TOPROG 87887 . 91839) (TAG#TOPROG 91841 . 92108) (
|
||||
TERM#TOPROG 92110 . 92423) (VAR#TOPROG 92425 . 92828) (VARDEF#TOPROG 92830 . 93525)) (111173 116115 (
|
||||
TRANSLATE.DUMPOUT 111183 . 115714) (TRANSLATE.SAVE.DUMPOUT 115716 . 116113)))))
|
||||
(FILEMAP (NIL (11391 38703 (IM.TEDIT 11401 . 13082) (DUMP 13084 . 15379) (DUMP.HEADERS.FOOTERS 15381
|
||||
. 17747) (DUMP.HRULE 17749 . 18900) (CHANGE.FONT 18902 . 20096) (IM.BOUT.IMAGEOBJ 20098 . 20421) (
|
||||
IM.TEDIT.DUMP.COMMANDS 20423 . 23976) (IM.TEDIT.DUMP.FOOTNOTES 23978 . 24419) (IM.TEDIT.DUMP.PARA
|
||||
24421 . 25195) (INDEXX.PARSE.TYPE 25197 . 26492) (FORMAT.DEF 26494 . 28625) (FORMAT.LISPWORD 28627 .
|
||||
28778) (MAKE.IM.DOCUMENT 28780 . 37558) (PRINT.NOTE 37560 . 37774) (SEND.INFO 37776 . 38701)) (38817
|
||||
42835 (IM.VRULE.DISPLAYFN 38827 . 39151) (CREATE.VRULE.OBJECT 39153 . 40933) (PRINT.VRULES.ON.PAGE
|
||||
40935 . 42833)) (42997 47752 (IM.FOLIO.DISPLAYFN 43007 . 43685) (IM.FOLIO.SIZEFN 43687 . 44536) (
|
||||
CREATE.FOLIO.OBJECT 44538 . 46084) (GET.FOLIO.STRING 46086 . 47750)) (47888 94128 (ARG#TOPROG 47898 .
|
||||
48037) (BIGLISPCODE#TOPROG 48039 . 49275) (BRACKET#TOPROG 49277 . 49441) (CHAPTER#TOPROG 49443 . 52124
|
||||
) (COMMENT#TOPROG 52126 . 52678) (DEF#TOPROG 52680 . 56015) (FIGURE#TOPROG 56017 . 57361) (FN#TOPROG
|
||||
57363 . 57760) (FNDEF#TOPROG 57762 . 61654) (FOOT#TOPROG 61656 . 62197) (INCLUDE#TOPROG 62199 . 62514)
|
||||
(INDEX#TOPROG 62516 . 63606) (INDEXX#TOPROG 63608 . 65689) (IT#TOPROG 65691 . 65832) (LBRACKET#TOPROG
|
||||
65834 . 65988) (LISP#TOPROG 65990 . 66131) (LISPCODE#TOPROG 66133 . 67252) (LISPWORD#TOPROG 67254 .
|
||||
67994) (LIST#TOPROG 67996 . 72418) (MACDEF#TOPROG 72420 . 73598) (NOTE#TOPROG 73600 . 74280) (
|
||||
PRINT.SPECIAL.CHARS#TOPROG 74282 . 75259) (PROPDEF#TOPROG 75261 . 75538) (RBRACKET#TOPROG 75540 .
|
||||
75694) (REF#TOPROG 75696 . 83535) (RM#TOPROG 83537 . 83675) (SUB#TOPROG 83677 . 83825) (SUBSEC#TOPROG
|
||||
83827 . 88330) (SUPER#TOPROG 88332 . 88486) (TABLE#TOPROG 88488 . 92440) (TAG#TOPROG 92442 . 92709) (
|
||||
TERM#TOPROG 92711 . 93024) (VAR#TOPROG 93026 . 93429) (VARDEF#TOPROG 93431 . 94126)) (111920 116862 (
|
||||
TRANSLATE.DUMPOUT 111930 . 116461) (TRANSLATE.SAVE.DUMPOUT 116463 . 116860)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,10 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "29-Apr-2024 16:25:20" {DSK}<home>larry>il>medley>internal>MEDLEY-UTILS.;9 28903
|
||||
(FILECREATED "14-Jul-2024 12:51:12" {DSK}<home>frank>il>medley>internal>MEDLEY-UTILS.;16 30093
|
||||
|
||||
:EDIT-BY "lmm"
|
||||
:CHANGES-TO (FNS MAKE-INDEX-HTMLS)
|
||||
|
||||
:PREVIOUS-DATE "26-Apr-2024 16:34:08" {DSK}<home>larry>il>medley>internal>MEDLEY-UTILS.;8)
|
||||
:PREVIOUS-DATE "13-Jul-2024 23:39:43" {DSK}<home>frank>il>medley>internal>MEDLEY-UTILS.;14)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT MEDLEY-UTILSCOMS)
|
||||
@@ -124,13 +124,16 @@
|
||||
"Welcome to Fuller sysout"])
|
||||
|
||||
(MAKE-INDEX-HTMLS
|
||||
[LAMBDA (BASE TOP) (* ; "Edited 29-Apr-2024 14:18 by lmm")
|
||||
[LAMBDA (BASE TOP LEVEL) (* ; "Edited 29-Apr-2024 14:18 by lmm")
|
||||
(* ; "Edited 26-Apr-2024 16:15 by lmm")
|
||||
(* ; "Edited 20-Apr-2024 12:34 by lmm")
|
||||
(* ; "Edited 13-Apr-2024 21:18 by lmm")
|
||||
[OR BASE (SETQ BASE (PSEUDOFILENAME (MEDLEYDIR]
|
||||
(OR (DIRECTORYNAMEP BASE)
|
||||
(ERROR BASE "not a directory name"))
|
||||
(OR (AND (NUMBERP LEVEL)
|
||||
(IGREATERP LEVEL 0))
|
||||
(SETQ LEVEL 1))
|
||||
(LET* ((SUBDIRS NIL)
|
||||
(DEST (PACKFILENAME 'NAME "index" 'EXTENSION "html" 'VERSION NIL 'BODY BASE))
|
||||
(PSEUDOHOST (EQ (NTHCHAR BASE (CL:1- 0))
|
||||
@@ -138,9 +141,20 @@
|
||||
SLASHED SHORTNAME)
|
||||
(CL:WITH-OPEN-FILE
|
||||
(S DEST :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :IF-DOES-NOT-EXIST :CREATE)
|
||||
(CL:FORMAT S "<HTML><HEAD><TITLE>Index page for ~a</TITLE></HEAD>~%%" (SETQ SLASHED
|
||||
(SLASHIT BASE)))
|
||||
(CL:FORMAT S "<HTML>~%%<HEAD>~%%")
|
||||
(CL:FORMAT S "<TITLE>Index page for ~a</TITLE>~%%" (SETQ SLASHED (SLASHIT BASE)))
|
||||
(CL:FORMAT S "<SCRIPT>~%%")
|
||||
(CL:FORMAT S " function up_onclick(){~%%")
|
||||
(CL:FORMAT S " var newLoc = location.href.replace(/\/index.html$/i, %"%");~%%")
|
||||
(CL:FORMAT S " location = newLoc.replace(/\/[^\/]+\/?$/, %"%");~%%")
|
||||
(CL:FORMAT S " }~%%")
|
||||
(CL:FORMAT S "</SCRIPT>~%%")
|
||||
(CL:FORMAT S "</HEAD>~%%")
|
||||
(CL:FORMAT S "<BODY><H1>Index page for ~a</H1>~%%" SLASHED)
|
||||
(CL:UNLESS (EQ LEVEL 1)
|
||||
(CL:FORMAT S
|
||||
"<DIV>~%%<BUTTON TYPE=%"BUTTON%" ONCLICK=%"up_onclick()%">Go up one level</BUTTON>~%%</DIV>~%%"
|
||||
))
|
||||
(CL:FORMAT S "<P>This is an index of the files just to link them in.~%%<UL>~%%")
|
||||
(FOR FULLNAME IN (DIRECTORY (CONCAT BASE "*.*;"))
|
||||
DO (IF (EQ (NTHCHAR FULLNAME -1)
|
||||
@@ -181,7 +195,8 @@
|
||||
|
||||
ELSE (CL:FORMAT S "<LI><A HREF=%"~a%">~a</A></LI>~%%" SHORTNAME SHORTNAME)))
|
||||
(CL:FORMAT S "</UL></BODY></HTML>~%%"))
|
||||
(NCONC SUBDIRS (FOR D IN SUBDIRS join (MAKE-INDEX-HTMLS D (OR TOP BASE])
|
||||
(NCONC SUBDIRS (FOR D IN SUBDIRS join (MAKE-INDEX-HTMLS D (OR TOP BASE)
|
||||
(ADD1 LEVEL])
|
||||
|
||||
(MEDLEY-FIX-LINKS
|
||||
[LAMBDA (UNIXPATH) (* ; "Edited 18-Jan-2021 12:01 by larry")
|
||||
@@ -258,7 +273,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(HCFILES
|
||||
[LAMBDA (BASE REDO SUBSETS) (* ; "Edited 23-Apr-2024 23:15 by lmm")
|
||||
[LAMBDA (BASE REDO SUBSETS) (* ; "Edited 30-Jun-2024 08:27 by lmm")
|
||||
(* ; "Edited 23-Apr-2024 23:15 by lmm")
|
||||
(* ; "Edited 22-Apr-2024 13:22 by lmm")
|
||||
(* ; "Edited 5-Feb-2024 12:16 by lmm")
|
||||
(* ; "Edited 4-Nov-2023 11:14 by lmm")
|
||||
@@ -302,12 +318,7 @@
|
||||
(* ;;
|
||||
" doesnt (yet) implement / to - translattion. .readme should show up as -.readme.")
|
||||
|
||||
(SETQ DEST (PACKFILENAME 'EXTENSION 'pdf 'NAME
|
||||
(IF EXT
|
||||
THEN (LISTGET SRC 'NAME)
|
||||
ELSE (PACK* (LISTGET SRC 'NAME)
|
||||
'-src))
|
||||
'BODY NOV))
|
||||
(SETQ DEST (CONCAT NOV ".pdf"))
|
||||
(CL:WHEN (AND (NOT REDO)
|
||||
(INFILEP DEST))
|
||||
(CL:FORMAT T "~a already there~%%" DEST)
|
||||
@@ -338,13 +349,16 @@
|
||||
(PRINTOUT T "DONE" T))])
|
||||
|
||||
(MAKE-INDEX-HTMLS
|
||||
[LAMBDA (BASE TOP) (* ; "Edited 29-Apr-2024 14:18 by lmm")
|
||||
[LAMBDA (BASE TOP LEVEL) (* ; "Edited 29-Apr-2024 14:18 by lmm")
|
||||
(* ; "Edited 26-Apr-2024 16:15 by lmm")
|
||||
(* ; "Edited 20-Apr-2024 12:34 by lmm")
|
||||
(* ; "Edited 13-Apr-2024 21:18 by lmm")
|
||||
[OR BASE (SETQ BASE (PSEUDOFILENAME (MEDLEYDIR]
|
||||
(OR (DIRECTORYNAMEP BASE)
|
||||
(ERROR BASE "not a directory name"))
|
||||
(OR (AND (NUMBERP LEVEL)
|
||||
(IGREATERP LEVEL 0))
|
||||
(SETQ LEVEL 1))
|
||||
(LET* ((SUBDIRS NIL)
|
||||
(DEST (PACKFILENAME 'NAME "index" 'EXTENSION "html" 'VERSION NIL 'BODY BASE))
|
||||
(PSEUDOHOST (EQ (NTHCHAR BASE (CL:1- 0))
|
||||
@@ -352,9 +366,20 @@
|
||||
SLASHED SHORTNAME)
|
||||
(CL:WITH-OPEN-FILE
|
||||
(S DEST :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :IF-DOES-NOT-EXIST :CREATE)
|
||||
(CL:FORMAT S "<HTML><HEAD><TITLE>Index page for ~a</TITLE></HEAD>~%%" (SETQ SLASHED
|
||||
(SLASHIT BASE)))
|
||||
(CL:FORMAT S "<HTML>~%%<HEAD>~%%")
|
||||
(CL:FORMAT S "<TITLE>Index page for ~a</TITLE>~%%" (SETQ SLASHED (SLASHIT BASE)))
|
||||
(CL:FORMAT S "<SCRIPT>~%%")
|
||||
(CL:FORMAT S " function up_onclick(){~%%")
|
||||
(CL:FORMAT S " var newLoc = location.href.replace(/\/index.html$/i, %"%");~%%")
|
||||
(CL:FORMAT S " location = newLoc.replace(/\/[^\/]+\/?$/, %"%");~%%")
|
||||
(CL:FORMAT S " }~%%")
|
||||
(CL:FORMAT S "</SCRIPT>~%%")
|
||||
(CL:FORMAT S "</HEAD>~%%")
|
||||
(CL:FORMAT S "<BODY><H1>Index page for ~a</H1>~%%" SLASHED)
|
||||
(CL:UNLESS (EQ LEVEL 1)
|
||||
(CL:FORMAT S
|
||||
"<DIV>~%%<BUTTON TYPE=%"BUTTON%" ONCLICK=%"up_onclick()%">Go up one level</BUTTON>~%%</DIV>~%%"
|
||||
))
|
||||
(CL:FORMAT S "<P>This is an index of the files just to link them in.~%%<UL>~%%")
|
||||
(FOR FULLNAME IN (DIRECTORY (CONCAT BASE "*.*;"))
|
||||
DO (IF (EQ (NTHCHAR FULLNAME -1)
|
||||
@@ -395,7 +420,8 @@
|
||||
|
||||
ELSE (CL:FORMAT S "<LI><A HREF=%"~a%">~a</A></LI>~%%" SHORTNAME SHORTNAME)))
|
||||
(CL:FORMAT S "</UL></BODY></HTML>~%%"))
|
||||
(NCONC SUBDIRS (FOR D IN SUBDIRS join (MAKE-INDEX-HTMLS D (OR TOP BASE])
|
||||
(NCONC SUBDIRS (FOR D IN SUBDIRS join (MAKE-INDEX-HTMLS D (OR TOP BASE)
|
||||
(ADD1 LEVEL])
|
||||
)
|
||||
|
||||
(PUTPROPS MEDLEY-UTILS FILETYPE :COMPILE-FILE)
|
||||
@@ -502,9 +528,9 @@
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1064 11630 (GATHER-INFO 1074 . 6456) (MAKE-FULLER-DB 6458 . 7235) (MAKE-INDEX-HTMLS
|
||||
7237 . 10999) (MEDLEY-FIX-LINKS 11001 . 11394) (MEDLEY-FIX-DATES 11396 . 11628)) (12809 15597 (
|
||||
MAKE-EXPORTS-ALL 12819 . 13878) (MAKE-WHEREIS-HASH 13880 . 15069) (MAKE-WHEREIS-LOOPS 15071 . 15595))
|
||||
(15598 23855 (HCFILES 15608 . 20089) (MAKE-INDEX-HTMLS 20091 . 23853)) (24105 28717 (RECOMPILE-ONE
|
||||
24115 . 26012) (RECMPL 26014 . 26617) (COMPILE-SETUP 26619 . 27243) (REMAKEFILES 27245 . 28715)))))
|
||||
(FILEMAP (NIL (1086 12345 (GATHER-INFO 1096 . 6478) (MAKE-FULLER-DB 6480 . 7257) (MAKE-INDEX-HTMLS
|
||||
7259 . 11714) (MEDLEY-FIX-LINKS 11716 . 12109) (MEDLEY-FIX-DATES 12111 . 12343)) (13524 16312 (
|
||||
MAKE-EXPORTS-ALL 13534 . 14593) (MAKE-WHEREIS-HASH 14595 . 15784) (MAKE-WHEREIS-LOOPS 15786 . 16310))
|
||||
(16313 25045 (HCFILES 16323 . 20586) (MAKE-INDEX-HTMLS 20588 . 25043)) (25295 29907 (RECOMPILE-ONE
|
||||
25305 . 27202) (RECMPL 27204 . 27807) (COMPILE-SETUP 27809 . 28433) (REMAKEFILES 28435 . 29905)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,14 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "27-Mar-2024 23:07:42" {WMEDLEY}<library>UNICODE.;73 100984
|
||||
(FILECREATED "26-Aug-2024 16:58:36" {WMEDLEY}<library>UNICODE.;74 100982
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS UNICODE-EXTEND-TRANSLATION? INVERT-ALL-UNICODE-MAPPINGS ALL-UNICODE-MAPPINGS
|
||||
MERGE-UNICODE-TRANSLATION-TABLES)
|
||||
(VARS UNICODECOMS)
|
||||
:CHANGES-TO (FNS UNICODE-EXTEND-TRANSLATION?)
|
||||
|
||||
:PREVIOUS-DATE "27-Mar-2024 14:50:54" {WMEDLEY}<library>UNICODE.;72)
|
||||
:PREVIOUS-DATE "27-Mar-2024 23:07:42" {WMEDLEY}<library>UNICODE.;73)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT UNICODECOMS)
|
||||
@@ -661,7 +659,8 @@
|
||||
NEXTCODE])
|
||||
|
||||
(UNICODE-EXTEND-TRANSLATION?
|
||||
[LAMBDA (CODE TRANSLATION-TABLE) (* ; "Edited 27-Mar-2024 23:02 by rmk")
|
||||
[LAMBDA (CODE TRANSLATION-TABLE) (* ; "Edited 26-Aug-2024 16:49 by rmk")
|
||||
(* ; "Edited 27-Mar-2024 23:02 by rmk")
|
||||
(* ; "Edited 5-Feb-2024 13:48 by rmk")
|
||||
(* ; "Edited 3-Feb-2024 12:40 by rmk")
|
||||
|
||||
@@ -673,11 +672,11 @@
|
||||
'UNICODE-MAPPINGS.TXT)
|
||||
T UNICODEDIRECTORIES))
|
||||
(CL:WHEN FILE
|
||||
(SETQ MAPPING (CL:WITH-OPEN-FILE (STREAM FILE :INPUT)
|
||||
(FFILEPOS (CONCAT "[" (LRSH CODE 8)
|
||||
" ")
|
||||
STREAM NIL NIL NIL T)
|
||||
(READ STREAM)))
|
||||
[SETQ MAPPING (CL:WITH-OPEN-FILE (STREAM FILE :INPUT)
|
||||
(CL:WHEN (FFILEPOS (CONCAT "[" (LRSH CODE 8)
|
||||
" ")
|
||||
STREAM NIL NIL NIL T)
|
||||
(READ STREAM]
|
||||
(CL:WHEN MAPPING
|
||||
|
||||
(* ;;
|
||||
@@ -1866,23 +1865,23 @@
|
||||
|
||||
(PUTPROPS UNICODE FILETYPE :TCOMPL)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4211 18357 (UTF8.OUTCHARFN 4221 . 7019) (UTF8.INCCODEFN 7021 . 12633) (UTF8.PEEKCCODEFN
|
||||
12635 . 17375) (\UTF8.BACKCCODEFN 17377 . 18355)) (18358 22612 (UTF16BE.OUTCHARFN 18368 . 19278) (
|
||||
UTF16BE.INCCODEFN 19280 . 20296) (UTF16BE.PEEKCCODEFN 20298 . 21529) (\UTF16BE.BACKCCODEFN 21531 .
|
||||
22610)) (22613 26900 (UTF16LE.OUTCHARFN 22623 . 23630) (UTF16LE.INCCODEFN 23632 . 24648) (
|
||||
UTF16LE.PEEKCCODEFN 24650 . 25817) (\UTF16LE.BACKCCODEFN 25819 . 26898)) (26901 29830 (READBOM 26911
|
||||
. 28915) (WRITEBOM 28917 . 29828)) (29860 33050 (MAKE-UNICODE-FORMATS 29870 . 33048)) (33147 41529 (
|
||||
UNICODE.UNMAPPED 33157 . 35231) (UNICODE-EXTEND-TRANSLATION? 35233 . 37152) (UTF8.BINCODE 37154 .
|
||||
39733) (\UTF8.FETCHCODE 39735 . 41527)) (41530 47051 (UTF8.VALIDATE 41540 . 44137) (
|
||||
UTF8-SIZE-FROM-BYTE1 44139 . 44571) (NUTF8-BYTE1-BYTES 44573 . 45310) (NUTF8-CODE-BYTES 45312 . 46369)
|
||||
(NUTF8-STRING-BYTES 46371 . 47049)) (48482 48831 (XTOUCODE 48492 . 48660) (UTOXCODE 48662 . 48829)) (
|
||||
49774 55820 (READ-UNICODE-MAPPING-FILENAMES 49784 . 52731) (READ-UNICODE-MAPPING 52733 . 55818)) (
|
||||
55887 69217 (MAKE-UNICODE-TRANSLATION-TABLES 55897 . 64969) (MERGE-UNICODE-TRANSLATION-TABLES 64971 .
|
||||
66105) (MERGE-UNICODE-TRANSLATION-TABLES1 66107 . 69215)) (69218 76326 (INVERT-ALL-UNICODE-MAPPINGS
|
||||
69228 . 72849) (ALL-UNICODE-MAPPINGS 72851 . 76324)) (77294 89725 (WRITE-UNICODE-MAPPING 77304 . 81054
|
||||
) (WRITE-UNICODE-INCLUDED 81056 . 85778) (WRITE-UNICODE-MAPPING-HEADER 85780 . 87028) (
|
||||
WRITE-UNICODE-MAPPING-FILENAME 87030 . 88560) (HEXSTRING 88562 . 89723)) (89726 90402 (
|
||||
XCCS-UTF8-AFTER-OPEN 89736 . 90400)) (92927 98429 (UTF8HEXSTRING 92937 . 95142) (XTOUSTRING 95144 .
|
||||
98064) (XCCSSTRING 98066 . 98427)) (98430 99318 (UNHEXSTRING 98440 . 99316)) (99319 100829 (SHOWCHARS
|
||||
99329 . 100827)))))
|
||||
(FILEMAP (NIL (4068 18214 (UTF8.OUTCHARFN 4078 . 6876) (UTF8.INCCODEFN 6878 . 12490) (UTF8.PEEKCCODEFN
|
||||
12492 . 17232) (\UTF8.BACKCCODEFN 17234 . 18212)) (18215 22469 (UTF16BE.OUTCHARFN 18225 . 19135) (
|
||||
UTF16BE.INCCODEFN 19137 . 20153) (UTF16BE.PEEKCCODEFN 20155 . 21386) (\UTF16BE.BACKCCODEFN 21388 .
|
||||
22467)) (22470 26757 (UTF16LE.OUTCHARFN 22480 . 23487) (UTF16LE.INCCODEFN 23489 . 24505) (
|
||||
UTF16LE.PEEKCCODEFN 24507 . 25674) (\UTF16LE.BACKCCODEFN 25676 . 26755)) (26758 29687 (READBOM 26768
|
||||
. 28772) (WRITEBOM 28774 . 29685)) (29717 32907 (MAKE-UNICODE-FORMATS 29727 . 32905)) (33004 41527 (
|
||||
UNICODE.UNMAPPED 33014 . 35088) (UNICODE-EXTEND-TRANSLATION? 35090 . 37150) (UTF8.BINCODE 37152 .
|
||||
39731) (\UTF8.FETCHCODE 39733 . 41525)) (41528 47049 (UTF8.VALIDATE 41538 . 44135) (
|
||||
UTF8-SIZE-FROM-BYTE1 44137 . 44569) (NUTF8-BYTE1-BYTES 44571 . 45308) (NUTF8-CODE-BYTES 45310 . 46367)
|
||||
(NUTF8-STRING-BYTES 46369 . 47047)) (48480 48829 (XTOUCODE 48490 . 48658) (UTOXCODE 48660 . 48827)) (
|
||||
49772 55818 (READ-UNICODE-MAPPING-FILENAMES 49782 . 52729) (READ-UNICODE-MAPPING 52731 . 55816)) (
|
||||
55885 69215 (MAKE-UNICODE-TRANSLATION-TABLES 55895 . 64967) (MERGE-UNICODE-TRANSLATION-TABLES 64969 .
|
||||
66103) (MERGE-UNICODE-TRANSLATION-TABLES1 66105 . 69213)) (69216 76324 (INVERT-ALL-UNICODE-MAPPINGS
|
||||
69226 . 72847) (ALL-UNICODE-MAPPINGS 72849 . 76322)) (77292 89723 (WRITE-UNICODE-MAPPING 77302 . 81052
|
||||
) (WRITE-UNICODE-INCLUDED 81054 . 85776) (WRITE-UNICODE-MAPPING-HEADER 85778 . 87026) (
|
||||
WRITE-UNICODE-MAPPING-FILENAME 87028 . 88558) (HEXSTRING 88560 . 89721)) (89724 90400 (
|
||||
XCCS-UTF8-AFTER-OPEN 89734 . 90398)) (92925 98427 (UTF8HEXSTRING 92935 . 95140) (XTOUSTRING 95142 .
|
||||
98062) (XCCSSTRING 98064 . 98425)) (98428 99316 (UNHEXSTRING 98438 . 99314)) (99317 100827 (SHOWCHARS
|
||||
99327 . 100825)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 7-Apr-2024 17:22:52" {WMEDLEY}<library>TEDIT>TEDIT-FILE.;531 155019
|
||||
(FILECREATED "11-Jul-2024 14:26:05" {MEDLEY}<library>TEDIT>TEDIT-FILE.;23 155256
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS \TEDIT.GET.CHARLOOKS.LIST \TEDIT.GET.SINGLE.CHARLOOKS \TEDIT.GET.PIECES3)
|
||||
:CHANGES-TO (FNS \TEDIT.GET.PIECES3)
|
||||
|
||||
:PREVIOUS-DATE " 2-Apr-2024 12:15:23" {WMEDLEY}<library>TEDIT>TEDIT-FILE.;529)
|
||||
:PREVIOUS-DATE " 7-Apr-2024 17:22:52" {MEDLEY}<library>TEDIT>TEDIT-FILE.;20)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TEDIT-FILECOMS)
|
||||
@@ -855,7 +855,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(\TEDIT.GET.PIECES3
|
||||
[LAMBDA (TEXT TEXTOBJ PCCOUNT CURFILEBYTE# END) (* ; "Edited 7-Apr-2024 17:20 by rmk")
|
||||
[LAMBDA (TEXT TEXTOBJ PCCOUNT CURFILEBYTE# END) (* ; "Edited 11-Jul-2024 14:20 by rmk")
|
||||
(* ; "Edited 7-Apr-2024 17:20 by rmk")
|
||||
(* ; "Edited 20-Mar-2024 10:59 by rmk")
|
||||
(* ; "Edited 15-Mar-2024 14:37 by rmk")
|
||||
(* ; "Edited 14-Jan-2024 00:22 by rmk")
|
||||
@@ -939,7 +940,9 @@
|
||||
(\TEDIT.GET.SINGLE.CHARLOOKS TEXT TEXTOBJ))))
|
||||
(\PieceDescriptorPAGEFRAME (* ;
|
||||
"This is page layout info for the file")
|
||||
(FSETTOBJ TEXTOBJ TXTPAGEFRAMES (\TEDIT.PARSE.PAGEFRAMES (READ TEXT))))
|
||||
(FSETTOBJ TEXTOBJ TXTPAGEFRAMES (\TEDIT.PARSE.PAGEFRAMES (READ TEXT
|
||||
*TEDIT-FILE-READTABLE*
|
||||
))))
|
||||
(\PieceDescriptorCHARLOOKSLIST (* ;
|
||||
"Read the list of CHARLOOKSs used in this document.")
|
||||
(add PCNO -1) (* ;
|
||||
@@ -2449,27 +2452,27 @@
|
||||
|
||||
(RPAQ? *TEDIT-FILE-READTABLE* (COPYREADTABLE \ORIGREADTABLE))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4804 30415 (TEDIT.GET 4814 . 9656) (TEDIT.FORMATTEDFILEP 9658 . 10974) (TEDIT.FILEDATE
|
||||
10976 . 12147) (TEDIT.INCLUDE 12149 . 19117) (TEDIT.RAW.INCLUDE 19119 . 19927) (TEDIT.PUT 19929 .
|
||||
26872) (TEDIT.PUT.STREAM 26874 . 30413)) (30416 49580 (\TEDIT.GET.FOREIGN.FILE 30426 . 33611) (
|
||||
\TEDIT.GET.UNFORMATTED.FILE 33613 . 37487) (\TEDIT.GET.FORMATTED.FILE 37489 . 40277) (
|
||||
\TEDIT.FORMATTEDSTREAMP 40279 . 43179) (\ARBIN 43181 . 43901) (\ATMIN 43903 . 44440) (\DWIN 44442 .
|
||||
44821) (\STRINGIN 44823 . 45531) (\TEDIT.GET.TRAILER 45533 . 48049) (\TEDIT.CACHEFILE 48051 . 49578))
|
||||
(49746 62858 (\TEDIT.GET.PIECES3 49756 . 59620) (\TEDIT.GET.IDATE3 59622 . 61017) (
|
||||
\TEDIT.MAKE.STRINGPIECE 61019 . 62856)) (62859 74802 (\TEDIT.GET.UNFORMATTED.FILE.XCCS 62869 . 68985)
|
||||
(\TEDIT.INTERPRET.XCCS.SHIFTS 68987 . 74800)) (74824 80846 (\TEDIT.GET.UNFORMATTED.FILE.UTF8 74834 .
|
||||
80844)) (80869 89373 (\TEDIT.GET.CHARLOOKS.LIST 80879 . 81610) (\TEDIT.GET.SINGLE.CHARLOOKS 81612 .
|
||||
86185) (\TEDIT.GET.CHARLOOKS 86187 . 87517) (\TEDIT.GET.PARALOOKS.INDEX 87519 . 88063) (
|
||||
\TEDIT.GET.CHARLOOKS.INDEX 88065 . 89371)) (89374 97612 (\TEDIT.GET.PARALOOKS.LIST 89384 . 90006) (
|
||||
\TEDIT.GET.SINGLE.PARALOOKS 90008 . 97020) (\TEDIT.GET.PARALOOKS 97022 . 97610)) (97613 101012 (
|
||||
\TEDIT.GET.OBJECT 97623 . 101010)) (101074 133645 (\TEDIT.PUT.PCTB 101084 . 115087) (
|
||||
\TEDIT.PUT.TRAILER 115089 . 115856) (\TEDIT.PUT.PCTB.MERGEABLE 115858 . 119376) (
|
||||
\TEDIT.PUT.UTF8.SPLITPIECES 119378 . 124465) (\TEDIT.PUT.PCTB.NEXTNEW 124467 . 128242) (
|
||||
\TEDIT.INSERT.NEWPIECES 128244 . 131243) (\TEDIT.PUTRESET 131245 . 131487) (\ARBOUT 131489 . 132213) (
|
||||
\ATMOUT 132215 . 132820) (\DWOUT 132822 . 133101) (\STRINGOUT 133103 . 133643)) (133646 145039 (
|
||||
\TEDIT.PUT.CHARLOOKS.LIST 133656 . 135328) (\TEDIT.PUT.SINGLE.CHARLOOKS 135330 . 140574) (
|
||||
\TEDIT.PUT.CHARLOOKS 140576 . 141720) (\TEDIT.PUT.CHARLOOKS1 141722 . 142773) (\TEDIT.PUT.OBJECT
|
||||
142775 . 145037)) (145040 153078 (\TEDIT.PUT.PARALOOKS.LIST 145050 . 145952) (
|
||||
\TEDIT.PUT.SINGLE.PARALOOKS 145954 . 152003) (\TEDIT.PUT.PARALOOKS 152005 . 153076)) (153173 154855 (
|
||||
TEDITFROMLISPSOURCE 153183 . 154853)))))
|
||||
(FILEMAP (NIL (4746 30357 (TEDIT.GET 4756 . 9598) (TEDIT.FORMATTEDFILEP 9600 . 10916) (TEDIT.FILEDATE
|
||||
10918 . 12089) (TEDIT.INCLUDE 12091 . 19059) (TEDIT.RAW.INCLUDE 19061 . 19869) (TEDIT.PUT 19871 .
|
||||
26814) (TEDIT.PUT.STREAM 26816 . 30355)) (30358 49522 (\TEDIT.GET.FOREIGN.FILE 30368 . 33553) (
|
||||
\TEDIT.GET.UNFORMATTED.FILE 33555 . 37429) (\TEDIT.GET.FORMATTED.FILE 37431 . 40219) (
|
||||
\TEDIT.FORMATTEDSTREAMP 40221 . 43121) (\ARBIN 43123 . 43843) (\ATMIN 43845 . 44382) (\DWIN 44384 .
|
||||
44763) (\STRINGIN 44765 . 45473) (\TEDIT.GET.TRAILER 45475 . 47991) (\TEDIT.CACHEFILE 47993 . 49520))
|
||||
(49688 63095 (\TEDIT.GET.PIECES3 49698 . 59857) (\TEDIT.GET.IDATE3 59859 . 61254) (
|
||||
\TEDIT.MAKE.STRINGPIECE 61256 . 63093)) (63096 75039 (\TEDIT.GET.UNFORMATTED.FILE.XCCS 63106 . 69222)
|
||||
(\TEDIT.INTERPRET.XCCS.SHIFTS 69224 . 75037)) (75061 81083 (\TEDIT.GET.UNFORMATTED.FILE.UTF8 75071 .
|
||||
81081)) (81106 89610 (\TEDIT.GET.CHARLOOKS.LIST 81116 . 81847) (\TEDIT.GET.SINGLE.CHARLOOKS 81849 .
|
||||
86422) (\TEDIT.GET.CHARLOOKS 86424 . 87754) (\TEDIT.GET.PARALOOKS.INDEX 87756 . 88300) (
|
||||
\TEDIT.GET.CHARLOOKS.INDEX 88302 . 89608)) (89611 97849 (\TEDIT.GET.PARALOOKS.LIST 89621 . 90243) (
|
||||
\TEDIT.GET.SINGLE.PARALOOKS 90245 . 97257) (\TEDIT.GET.PARALOOKS 97259 . 97847)) (97850 101249 (
|
||||
\TEDIT.GET.OBJECT 97860 . 101247)) (101311 133882 (\TEDIT.PUT.PCTB 101321 . 115324) (
|
||||
\TEDIT.PUT.TRAILER 115326 . 116093) (\TEDIT.PUT.PCTB.MERGEABLE 116095 . 119613) (
|
||||
\TEDIT.PUT.UTF8.SPLITPIECES 119615 . 124702) (\TEDIT.PUT.PCTB.NEXTNEW 124704 . 128479) (
|
||||
\TEDIT.INSERT.NEWPIECES 128481 . 131480) (\TEDIT.PUTRESET 131482 . 131724) (\ARBOUT 131726 . 132450) (
|
||||
\ATMOUT 132452 . 133057) (\DWOUT 133059 . 133338) (\STRINGOUT 133340 . 133880)) (133883 145276 (
|
||||
\TEDIT.PUT.CHARLOOKS.LIST 133893 . 135565) (\TEDIT.PUT.SINGLE.CHARLOOKS 135567 . 140811) (
|
||||
\TEDIT.PUT.CHARLOOKS 140813 . 141957) (\TEDIT.PUT.CHARLOOKS1 141959 . 143010) (\TEDIT.PUT.OBJECT
|
||||
143012 . 145274)) (145277 153315 (\TEDIT.PUT.PARALOOKS.LIST 145287 . 146189) (
|
||||
\TEDIT.PUT.SINGLE.PARALOOKS 146191 . 152240) (\TEDIT.PUT.PARALOOKS 152242 . 153313)) (153410 155092 (
|
||||
TEDITFROMLISPSOURCE 153420 . 155090)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "26-Mar-2024 21:42:47" {WMEDLEY}<lispusers>COMPAREDIRECTORIES.;259 131082
|
||||
(FILECREATED " 1-May-2024 14:53:20" {WMEDLEY}<lispusers>COMPAREDIRECTORIES.;260 131326
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS FIX-DIRECTORY-DATES)
|
||||
:CHANGES-TO (FNS COMPAREDIRECTORIES)
|
||||
|
||||
:PREVIOUS-DATE "29-Sep-2023 17:25:57" {WMEDLEY}<lispusers>COMPAREDIRECTORIES.;257)
|
||||
:PREVIOUS-DATE "26-Mar-2024 21:42:47" {WMEDLEY}<lispusers>COMPAREDIRECTORIES.;259)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT COMPAREDIRECTORIESCOMS)
|
||||
@@ -63,7 +63,8 @@
|
||||
|
||||
(COMPAREDIRECTORIES
|
||||
[LAMBDA (DIR1 DIR2 SELECT INCLUDEDFILES EXCLUDEDFILES USEDIRECTORYDATE OUTPUTFILE ALLVERSIONS
|
||||
FIXDIRECTORYDATES) (* ; "Edited 29-Sep-2023 17:25 by rmk")
|
||||
FIXDIRECTORYDATES SHORTDIRNAMES) (* ; "Edited 1-May-2024 14:52 by rmk")
|
||||
(* ; "Edited 29-Sep-2023 17:25 by rmk")
|
||||
(* ; "Edited 5-Apr-2023 10:12 by rmk")
|
||||
(* ; "Edited 29-Mar-2022 11:50 by rmk")
|
||||
(* ; "Edited 23-Feb-2022 21:10 by rmk")
|
||||
@@ -116,7 +117,11 @@
|
||||
(PRINTOUT T "Fixing directory dates" T)
|
||||
(FIX-DIRECTORY-DATES DIR1)
|
||||
(FIX-DIRECTORY-DATES DIR2))
|
||||
(CDPRINT.HEADER DIR1 DIR2 SELECT DATE T)
|
||||
(CDPRINT.HEADER (OR (CAR SHORTDIRNAMES)
|
||||
DIR1)
|
||||
(OR (CADR SHORTDIRNAMES)
|
||||
DIR2)
|
||||
SELECT DATE T)
|
||||
(PRINTOUT T " ... ")
|
||||
(SETQ INFOS1 (COMPAREDIRECTORIES.INFOS DIR1 INCLUDEDFILES EXCLUDEDFILES ALLVERSIONS DEPTH1
|
||||
USEDIRECTORYDATE (MEMB 'AUTHOR SELECT)))
|
||||
@@ -2197,25 +2202,25 @@
|
||||
|
||||
(MOVD? 'NILL 'TEDIT.FILEDATE)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2527 22645 (COMPAREDIRECTORIES 2537 . 7627) (COMPAREDIRECTORIES.INFOS 7629 . 10587) (
|
||||
COMPAREDIRECTORIES.CANDIDATES 10589 . 13974) (CDENTRIES.SELECT 13976 . 18751) (
|
||||
COMPAREDIRECTORIES.INFOS.TYPE 18753 . 19879) (MATCHNAME 19881 . 20561) (CD.INSURECDVALUE 20563 . 22177
|
||||
) (CD.UPDATEWIDTHS 22179 . 22643)) (22646 33268 (CDFILES 22656 . 28670) (CDFILES.MATCH 28672 . 30297)
|
||||
(CDFILES.PATS 30299 . 33266)) (33269 51090 (CDPRINT 33279 . 35796) (CDPRINT.HEADER 35798 . 36695) (
|
||||
CDPRINT.LINE 36697 . 39929) (CDPRINT.MAXWIDTHS 39931 . 44046) (CDPRINT.COLHEADERS 44048 . 45333) (
|
||||
CDPRINT.COLUMNS 45335 . 50455) (CDTEDIT 50457 . 51088)) (51091 60212 (CDMAP 51101 . 52533) (CDENTRY
|
||||
52535 . 52844) (CDSUBSET 52846 . 54285) (CDMERGE 54287 . 58271) (CDMERGE.COMMON 58273 . 59588) (
|
||||
CD.SORT 59590 . 60210)) (60213 67751 (BINCOMP 60223 . 64512) (EOLTYPE 64514 . 67076) (EOLTYPE.SHOW
|
||||
67078 . 67749)) (68279 80806 (FIND-UNCOMPILED-FILES 68289 . 71932) (FIND-UNSOURCED-FILES 71934 . 74318
|
||||
) (FIND-SOURCE-FILES 74320 . 76058) (FIND-COMPILED-FILES 76060 . 77937) (FIND-UNLOADED-FILES 77939 .
|
||||
78792) (FIND-LOADED-FILES 78794 . 79222) (FIND-MULTICOMPILED-FILES 79224 . 80804)) (80807 89238 (
|
||||
CREATED-AS 80817 . 85614) (SOURCE-FOR-COMPILED-P 85616 . 88543) (COMPILE-SOURCE-DATE-DIFF 88545 .
|
||||
89236)) (89239 100002 (FIX-DIRECTORY-DATES 89249 . 92699) (FIX-EQUIV-DATES 92701 . 94226) (
|
||||
COPY-COMPARED-FILES 94228 . 96049) (COPY-MISSING-FILES 96051 . 98208) (COMPILED-ON-SAME-SOURCE 98210
|
||||
. 100000)) (100196 108034 (CDBROWSER 100206 . 104133) (CDBROWSER.STRINGS 104135 . 108032)) (108196
|
||||
109932 (CD.TABLEITEM 108206 . 108426) (CD.TABLEITEM.PRINTFN 108428 . 108627) (CD.TABLEITEM.COPYFN
|
||||
108629 . 109687) (CDTABLEBROWSER.HEADING.REPAINTFN 109689 . 109930)) (109933 130588 (
|
||||
CDTABLEBROWSER.WHENSELECTEDFN 109943 . 110411) (CD.COMMANDSELECTEDFN 110413 . 115514) (CD-MENUFN
|
||||
115516 . 119827) (CD-COMPARE-FILES 119829 . 123181) (CDBROWSER-COPY 123183 . 126852) (
|
||||
CDBROWSER-DELETE-FILE 126854 . 130067) (CD-SWAPDIRS 130069 . 130586)))))
|
||||
(FILEMAP (NIL (2526 22889 (COMPAREDIRECTORIES 2536 . 7871) (COMPAREDIRECTORIES.INFOS 7873 . 10831) (
|
||||
COMPAREDIRECTORIES.CANDIDATES 10833 . 14218) (CDENTRIES.SELECT 14220 . 18995) (
|
||||
COMPAREDIRECTORIES.INFOS.TYPE 18997 . 20123) (MATCHNAME 20125 . 20805) (CD.INSURECDVALUE 20807 . 22421
|
||||
) (CD.UPDATEWIDTHS 22423 . 22887)) (22890 33512 (CDFILES 22900 . 28914) (CDFILES.MATCH 28916 . 30541)
|
||||
(CDFILES.PATS 30543 . 33510)) (33513 51334 (CDPRINT 33523 . 36040) (CDPRINT.HEADER 36042 . 36939) (
|
||||
CDPRINT.LINE 36941 . 40173) (CDPRINT.MAXWIDTHS 40175 . 44290) (CDPRINT.COLHEADERS 44292 . 45577) (
|
||||
CDPRINT.COLUMNS 45579 . 50699) (CDTEDIT 50701 . 51332)) (51335 60456 (CDMAP 51345 . 52777) (CDENTRY
|
||||
52779 . 53088) (CDSUBSET 53090 . 54529) (CDMERGE 54531 . 58515) (CDMERGE.COMMON 58517 . 59832) (
|
||||
CD.SORT 59834 . 60454)) (60457 67995 (BINCOMP 60467 . 64756) (EOLTYPE 64758 . 67320) (EOLTYPE.SHOW
|
||||
67322 . 67993)) (68523 81050 (FIND-UNCOMPILED-FILES 68533 . 72176) (FIND-UNSOURCED-FILES 72178 . 74562
|
||||
) (FIND-SOURCE-FILES 74564 . 76302) (FIND-COMPILED-FILES 76304 . 78181) (FIND-UNLOADED-FILES 78183 .
|
||||
79036) (FIND-LOADED-FILES 79038 . 79466) (FIND-MULTICOMPILED-FILES 79468 . 81048)) (81051 89482 (
|
||||
CREATED-AS 81061 . 85858) (SOURCE-FOR-COMPILED-P 85860 . 88787) (COMPILE-SOURCE-DATE-DIFF 88789 .
|
||||
89480)) (89483 100246 (FIX-DIRECTORY-DATES 89493 . 92943) (FIX-EQUIV-DATES 92945 . 94470) (
|
||||
COPY-COMPARED-FILES 94472 . 96293) (COPY-MISSING-FILES 96295 . 98452) (COMPILED-ON-SAME-SOURCE 98454
|
||||
. 100244)) (100440 108278 (CDBROWSER 100450 . 104377) (CDBROWSER.STRINGS 104379 . 108276)) (108440
|
||||
110176 (CD.TABLEITEM 108450 . 108670) (CD.TABLEITEM.PRINTFN 108672 . 108871) (CD.TABLEITEM.COPYFN
|
||||
108873 . 109931) (CDTABLEBROWSER.HEADING.REPAINTFN 109933 . 110174)) (110177 130832 (
|
||||
CDTABLEBROWSER.WHENSELECTEDFN 110187 . 110655) (CD.COMMANDSELECTEDFN 110657 . 115758) (CD-MENUFN
|
||||
115760 . 120071) (CD-COMPARE-FILES 120073 . 123425) (CDBROWSER-COPY 123427 . 127096) (
|
||||
CDBROWSER-DELETE-FILE 127098 . 130311) (CD-SWAPDIRS 130313 . 130830)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
File diff suppressed because one or more lines are too long
@@ -1,13 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 7-Feb-2024 16:08:54" {WMEDLEY}<lispusers>COMPARESOURCES.;137 40939
|
||||
(FILECREATED "13-Jun-2024 11:46:26" {WMEDLEY}<lispusers>COMPARESOURCES.;138 40991
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS COMPARESOURCESCOMS)
|
||||
(FNS COMPARESOURCES CSBROWSER \CS.IGNOREFORMS)
|
||||
:CHANGES-TO (FNS \CS.COMPARE.MASTERS)
|
||||
|
||||
:PREVIOUS-DATE "17-Jun-2023 15:22:40" {WMEDLEY}<lispusers>COMPARESOURCES.;131)
|
||||
:PREVIOUS-DATE " 7-Feb-2024 16:08:54" {WMEDLEY}<lispusers>COMPARESOURCES.;137)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT COMPARESOURCESCOMS)
|
||||
@@ -142,7 +141,8 @@
|
||||
'SAME])
|
||||
|
||||
(\CS.COMPARE.MASTERS
|
||||
[LAMBDA (BODY1 BODY2 DW?) (* ; "Edited 17-Jun-2023 15:19 by rmk")
|
||||
[LAMBDA (BODY1 BODY2 DW?) (* ; "Edited 13-Jun-2024 11:46 by rmk")
|
||||
(* ; "Edited 17-Jun-2023 15:19 by rmk")
|
||||
(* ; "Edited 25-Feb-2022 18:02 by rmk")
|
||||
(* ; "Edited 18-Jan-2022 22:00 by rmk")
|
||||
(* ; "Edited 19-Dec-2021 21:05 by rmk")
|
||||
@@ -155,8 +155,8 @@
|
||||
"We don't care about editdate comments")
|
||||
(SETQ BODY2 (CL:REMOVE-IF (FUNCTION EDITDATE?)
|
||||
BODY2))
|
||||
(SETQ BODY1 (\CS.FIXFNS BODY1))
|
||||
(SETQ BODY2 (\CS.FIXFNS BODY2))
|
||||
(SETQ BODY1 (\CS.FIXFNS BODY1 DW?))
|
||||
(SETQ BODY2 (\CS.FIXFNS BODY2 DW?))
|
||||
(CL:WHEN (AND (SETQ THING1 (ASSOC 'DEFINE-FILE-INFO BODY1))
|
||||
(SETQ THING2 (ASSOC 'DEFINE-FILE-INFO BODY2))
|
||||
(\CS.COMPARE.DEFINE-FILE-INFO THING1 THING2))
|
||||
@@ -703,17 +703,17 @@
|
||||
)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1748 26130 (COMPARESOURCES 1758 . 8406) (\CS.COMPARE.MASTERS 8408 . 15929) (
|
||||
\CS.COMPARE.TYPES 15931 . 19197) (\CS.EXAMINE 19199 . 22377) (\CS.FIXFNS 22379 . 23881) (
|
||||
\CS.SORT.DECLARES 23883 . 24226) (\CS.SORT.DECLARE1 24228 . 25648) (\CS.FILTER.GARBAGE 25650 . 26128))
|
||||
(26131 31474 (\CS.ISFNFORM 26141 . 26409) (\CS.COMPARE.FNS 26411 . 26653) (\CS.FNSID 26655 . 26799) (
|
||||
\CS.ISVARFORM 26801 . 26906) (\CS.COMPARE.VARS 26908 . 27570) (\CS.ISMACROFORM 27572 . 27710) (
|
||||
\CS.ISRECFORM 27712 . 28040) (\CS.REC.NAME 28042 . 28361) (\CS.ISCOURIERFORM 28363 . 28463) (
|
||||
\CS.ISTEMPLATEFORM 28465 . 28563) (\CS.COMPARE.TEMPLATES 28565 . 28930) (\CS.ISPROPFORM 28932 . 29087)
|
||||
(\CS.PROP.NAME 29089 . 29234) (\CS.COMPARE.PROPS 29236 . 29393) (\CS.ISADDVARFORM 29395 . 29488) (
|
||||
\CS.COMPARE.ADDVARS 29490 . 29655) (\CS.ISFPKGCOMFORM 29657 . 29864) (\CS.COMPARE.FPKGCOMS 29866 .
|
||||
30073) (\CS.COMPARE.DEFINE-FILE-INFO 30075 . 30665) (\CS.IGNOREFORMS 30667 . 31472)) (31475 37539 (
|
||||
CSOBJ.CREATE 31485 . 31898) (CSOBJ.DISPLAYFN 31900 . 32653) (CSOBJ.IMAGEBOXFN 32655 . 34816) (
|
||||
CSOBJ.BUTTONEVENTINFN 34818 . 37289) (CSOBJ.COPYBUTTONEVENTINFN 37291 . 37537)) (38420 40605 (
|
||||
CSBROWSER 38430 . 40603)))))
|
||||
(FILEMAP (NIL (1683 26182 (COMPARESOURCES 1693 . 8341) (\CS.COMPARE.MASTERS 8343 . 15981) (
|
||||
\CS.COMPARE.TYPES 15983 . 19249) (\CS.EXAMINE 19251 . 22429) (\CS.FIXFNS 22431 . 23933) (
|
||||
\CS.SORT.DECLARES 23935 . 24278) (\CS.SORT.DECLARE1 24280 . 25700) (\CS.FILTER.GARBAGE 25702 . 26180))
|
||||
(26183 31526 (\CS.ISFNFORM 26193 . 26461) (\CS.COMPARE.FNS 26463 . 26705) (\CS.FNSID 26707 . 26851) (
|
||||
\CS.ISVARFORM 26853 . 26958) (\CS.COMPARE.VARS 26960 . 27622) (\CS.ISMACROFORM 27624 . 27762) (
|
||||
\CS.ISRECFORM 27764 . 28092) (\CS.REC.NAME 28094 . 28413) (\CS.ISCOURIERFORM 28415 . 28515) (
|
||||
\CS.ISTEMPLATEFORM 28517 . 28615) (\CS.COMPARE.TEMPLATES 28617 . 28982) (\CS.ISPROPFORM 28984 . 29139)
|
||||
(\CS.PROP.NAME 29141 . 29286) (\CS.COMPARE.PROPS 29288 . 29445) (\CS.ISADDVARFORM 29447 . 29540) (
|
||||
\CS.COMPARE.ADDVARS 29542 . 29707) (\CS.ISFPKGCOMFORM 29709 . 29916) (\CS.COMPARE.FPKGCOMS 29918 .
|
||||
30125) (\CS.COMPARE.DEFINE-FILE-INFO 30127 . 30717) (\CS.IGNOREFORMS 30719 . 31524)) (31527 37591 (
|
||||
CSOBJ.CREATE 31537 . 31950) (CSOBJ.DISPLAYFN 31952 . 32705) (CSOBJ.IMAGEBOXFN 32707 . 34868) (
|
||||
CSOBJ.BUTTONEVENTINFN 34870 . 37341) (CSOBJ.COPYBUTTONEVENTINFN 37343 . 37589)) (38472 40657 (
|
||||
CSBROWSER 38482 . 40655)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
Binary file not shown.
420
lispusers/GITFNS
420
lispusers/GITFNS
@@ -1,12 +1,16 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "20-May-2024 22:13:04" {WMEDLEY}<lispusers>GITFNS.;530 131382
|
||||
(FILECREATED "12-Jun-2024 23:02:26" {DSK}<home>matt>Interlisp>medley>lispusers>GITFNS.;6 133403
|
||||
|
||||
:EDIT-BY rmk
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (FNS GIT-PULL-REQUESTS)
|
||||
:CHANGES-TO (FNS PRC-COMMAND GIT-BRANCH-RELATIONS GIT-BRANCHES GIT-BRANCH-MENU
|
||||
GIT-PULL-REQUESTS GIT-PRC-BRANCHES CDGITDIR GIT-COMMAND GITORIGIN
|
||||
GIT-RESULT-TO-LINES STRIPLOCAL GIT-WHICH-BRANCH GIT-GET-DIFFERENT-FILES
|
||||
GIT-REMOTE-UPDATE GIT-CHECKOUT GIT-MAKE-BRANCH GIT-MY-BRANCHP
|
||||
GIT-BRANCHES-COMPARE-DIRECTORIES GIT-WORKING-COMPARE-DIRECTORIES)
|
||||
|
||||
:PREVIOUS-DATE "13-May-2024 19:31:18" {WMEDLEY}<lispusers>GITFNS.;529)
|
||||
:PREVIOUS-DATE "10-Jun-2024 18:43:43" {DSK}<home>matt>Interlisp>medley>lispusers>GITFNS.;5)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT GITFNSCOMS)
|
||||
@@ -294,24 +298,24 @@
|
||||
(* ; "Edited 13-May-2022 10:40 by rmk")
|
||||
(* ; "Edited 9-May-2022 20:02 by rmk")
|
||||
(* ; "Edited 8-May-2022 11:38 by rmk")
|
||||
(CL:WHEN (SETQ PROJECT (IF (TYPE? GIT-PROJECT PROJECT)
|
||||
THEN PROJECT
|
||||
ELSEIF (CDR (ASSOC (OR (U-CASE PROJECT)
|
||||
(CL:WHEN (SETQ PROJECT (if (type? GIT-PROJECT PROJECT)
|
||||
then PROJECT
|
||||
elseif (CDR (ASSOC (OR (U-CASE PROJECT)
|
||||
GIT-DEFAULT-PROJECT)
|
||||
GIT-PROJECTS))
|
||||
ELSEIF NOERROR
|
||||
THEN NIL
|
||||
ELSE (ERROR "NOT A GIT-PROJECT" PROJECT)))
|
||||
elseif NOERROR
|
||||
then NIL
|
||||
else (ERROR "NOT A GIT-PROJECT" PROJECT)))
|
||||
(SELECTQ FIELD
|
||||
(PROJECTNAME (FETCH PROJECTNAME OF PROJECT))
|
||||
(WHOST (FETCH WHOST OF PROJECT))
|
||||
(GITHOST (FETCH GITHOST OF PROJECT))
|
||||
(EXCLUSIONS (FETCH EXCLUSIONS OF PROJECT))
|
||||
(PROJECTNAME (fetch PROJECTNAME of PROJECT))
|
||||
(WHOST (fetch WHOST of PROJECT))
|
||||
(GITHOST (fetch GITHOST of PROJECT))
|
||||
(EXCLUSIONS (fetch EXCLUSIONS of PROJECT))
|
||||
(DEFAULTSUBDIRS
|
||||
(FETCH DEFAULTSUBDIRS OF PROJECT))
|
||||
(CLONEPATH (FETCH CLONEPATH OF PROJECT))
|
||||
(MAINBRANCH [OR (FETCH MAINBRANCH OF PROJECT)
|
||||
(REPLACE MAINBRANCH OF PROJECT WITH (OR (GIT-BRANCH-EXISTS? 'origin/main
|
||||
(fetch DEFAULTSUBDIRS of PROJECT))
|
||||
(CLONEPATH (fetch CLONEPATH of PROJECT))
|
||||
(MAINBRANCH [OR (fetch MAINBRANCH of PROJECT)
|
||||
(replace MAINBRANCH of PROJECT with (OR (GIT-BRANCH-EXISTS? 'origin/main
|
||||
T PROJECT)
|
||||
(GIT-BRANCH-EXISTS?
|
||||
'origin/master NIL PROJECT
|
||||
@@ -543,13 +547,13 @@
|
||||
(* ;; "DRAFTS can be DRAFT(S), NODRAFTS, or NIL. If DRAFTS, then only draft PR's are shown, of NODRAFTS then only nondrafts are shown. Anything else, both drafts and nondrafts are shown in the menu.")
|
||||
|
||||
(LET (PRS MENUWINDOW OLDMENUWINDOW)
|
||||
(IF PROJECT
|
||||
THEN (SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
ELSEIF (GIT-GET-PROJECT REMOTEBRANCH NIL T)
|
||||
THEN (SETQ PROJECT REMOTEBRANCH)
|
||||
(if PROJECT
|
||||
then (SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
elseif (GIT-GET-PROJECT REMOTEBRANCH NIL T)
|
||||
then (SETQ PROJECT REMOTEBRANCH)
|
||||
(SETQ REMOTEBRANCH NIL)
|
||||
ELSEIF (GIT-GET-PROJECT DRAFTS NIL T)
|
||||
THEN (SETQ PROJECT DRAFTS)
|
||||
elseif (GIT-GET-PROJECT DRAFTS NIL T)
|
||||
then (SETQ PROJECT DRAFTS)
|
||||
(SETQ DRAFTS NIL))
|
||||
(CL:UNLESS PROJECT (SETQ PROJECT GIT-DEFAULT-PROJECT))
|
||||
(SELECTQ (U-CASE REMOTEBRANCH)
|
||||
@@ -584,8 +588,8 @@
|
||||
(fetch PRLOGIN of PR)
|
||||
")" T)
|
||||
NIL) collect PR))
|
||||
(IF PRS
|
||||
THEN (if (CDR PRS)
|
||||
(if PRS
|
||||
then (if (CDR PRS)
|
||||
then (SETQ MENUWINDOW (ADDMENU (GIT-BRANCH-MENU (GIT-PRC-BRANCHES DRAFTS
|
||||
PROJECT PRS)
|
||||
(CONCAT (LENGTH PRS)
|
||||
@@ -602,12 +606,12 @@
|
||||
(CL:WHEN [OPENWP (CDR (SETQ OLDMENUWINDOW (ASSOC PROJECT GIT-PRC-MENUS]
|
||||
(CLOSEW (CDR OLDMENUWINDOW)))
|
||||
(OPENW MENUWINDOW)
|
||||
(RPLACD [OR OLDMENUWINDOW (CAR (PUSH GIT-PRC-MENUS (CONS PROJECT]
|
||||
(RPLACD [OR OLDMENUWINDOW (CAR (push GIT-PRC-MENUS (CONS PROJECT]
|
||||
MENUWINDOW)
|
||||
MENUWINDOW
|
||||
else (GIT-PR-COMPARE (fetch PRNAME of (CAR PRS))
|
||||
PROJECT))
|
||||
ELSE (CONCAT "No open " (OR REMOTEBRANCH "")
|
||||
else (CONCAT "No open " (OR REMOTEBRANCH "")
|
||||
" pull requests"])
|
||||
)
|
||||
|
||||
@@ -970,7 +974,8 @@
|
||||
|
||||
(GIT-REMOTE-UPDATE
|
||||
[LAMBDA (DOIT PROJECT)
|
||||
(DECLARE (USEDFREE LAST-REMOTE-UPDATE-IDATE)) (* ; "Edited 7-May-2022 22:41 by rmk")
|
||||
(DECLARE (USEDFREE LAST-REMOTE-UPDATE-IDATE)) (* ; "Edited 12-Jun-2024 12:57 by mth")
|
||||
(* ; "Edited 7-May-2022 22:41 by rmk")
|
||||
|
||||
(* ;; "Because git hangs on this (and other things), do this no more than once a day")
|
||||
|
||||
@@ -978,7 +983,7 @@
|
||||
(IGREATERP (IDIFFERENCE (IDATE)
|
||||
LAST-REMOTE-UPDATE-IDATE)
|
||||
(CONSTANT (TIMES 24 60 60 1000]
|
||||
(PRINTOUT T "Updating from remote, local branch is " (GIT-WHICH-BRANCH PROJECT)
|
||||
(PRINTOUT T "Updating from remote, local branch is " (GIT-WHICH-BRANCH PROJECT T)
|
||||
T)
|
||||
(PROG1 (GIT-COMMAND "git remote update origin" NIL PROJECT)
|
||||
(SETQ LAST-REMOTE-UPDATE-IDATE (IDATE))))])
|
||||
@@ -1078,6 +1083,8 @@
|
||||
(GIT-BRANCH-DIFF
|
||||
[LAMBDA (BRANCH1 BRANCH2 PROJECT)
|
||||
|
||||
(* ;; "Edited 10-Jun-2024 16:43 by mth")
|
||||
|
||||
(* ;; "Edited 2-May-2024 11:28 by mth")
|
||||
|
||||
(* ;; "Edited 29-Sep-2022 10:52 by rmk")
|
||||
@@ -1117,10 +1124,10 @@
|
||||
(SETQ RLINES NIL)
|
||||
(CL:WHEN (LISTP RESULTFILE)
|
||||
(SETQ ERRORFILE (CADR RESULTFILE))
|
||||
(SETQ ELINES (GIT-RESULT-TO-LINES ERRORFILE))
|
||||
(SETQ ELINES (GIT-RESULT-TO-LINES ERRORFILE T))
|
||||
(DELFILE ERRORFILE)
|
||||
(SETQ RESULTFILE (CAR RESULTFILE)))
|
||||
(SETQ RLINES (GIT-RESULT-TO-LINES RESULTFILE))
|
||||
(SETQ RLINES (GIT-RESULT-TO-LINES RESULTFILE T))
|
||||
(DELFILE RESULTFILE)
|
||||
(CL:WHEN ELINES
|
||||
(if [AND (STRPOS "warning: inexact rename detection was skipped due to too many files."
|
||||
@@ -1141,30 +1148,32 @@
|
||||
(GO RETRY))
|
||||
(ERROR "Incomplete branch differences" (LIST BRANCH1 BRANCH2)))
|
||||
else (for L in ELINES do (PRINTOUT T L T))))
|
||||
(RETURN (SORT (for L in RLINES
|
||||
(RETURN (SORT (for (L FN) in RLINES
|
||||
collect (SELCHARQ (CHCON1 L)
|
||||
(A (CL:IF (EQ (CHARCODE TAB)
|
||||
(NTHCHARCODE L 2))
|
||||
(LIST 'ADDED (SUBSTRING L 3))
|
||||
(LIST 'ADDED (SETQ FN (SUBSTRING L 3)))
|
||||
(ERROR "ADDED NOT RECOGNIZED" L)))
|
||||
(D (CL:IF (EQ (CHARCODE TAB)
|
||||
(NTHCHARCODE L 2))
|
||||
(LIST 'DELETED (SUBSTRING L 3))
|
||||
(LIST 'DELETED (SETQ FN (SUBSTRING L 3)))
|
||||
(ERROR "DELETED NOT RECOGNIZED" L)))
|
||||
(M (CL:IF (SETQ POS (STRPOS " " L))
|
||||
(LIST 'CHANGED (SUBSTRING L (ADD1 POS)))
|
||||
[LIST 'CHANGED (SETQ FN (SUBSTRING L (ADD1 POS]
|
||||
(ERROR "CHANGED NOT RECOGNIZED" L)))
|
||||
(C (if (AND (EQ (CHARCODE TAB)
|
||||
(NTHCHARCODE L 5))
|
||||
(SETQ POS (STRPOS " " L 7)))
|
||||
then (LIST 'COPIED (SUBSTRING L 6 (SUB1 POS))
|
||||
then (LIST 'COPIED (SETQ FN (SUBSTRING L 6
|
||||
(SUB1 POS)))
|
||||
(OR (FIXP (SUBATOM L 2 4))
|
||||
(HELP "C without a number" L)))
|
||||
else (HELP "COPY NOT RECOGNIZED" L)))
|
||||
(R (if (AND (EQ (CHARCODE TAB)
|
||||
(NTHCHARCODE L 5))
|
||||
(SETQ POS (STRPOS " " L 7)))
|
||||
then (LIST 'RENAMED (SUBSTRING L 6 (SUB1 POS))
|
||||
then (LIST 'RENAMED (SETQ FN (SUBSTRING L 6
|
||||
(SUB1 POS)))
|
||||
(SUBSTRING L (ADD1 POS))
|
||||
(OR (FIXP (SUBATOM L 2 4))
|
||||
(HELP "R without a number" L)))
|
||||
@@ -1175,7 +1184,8 @@
|
||||
" Ignore remaining files? "
|
||||
)))
|
||||
(ERROR!)))
|
||||
(HELP "Unrecognized git-diff code " L)))
|
||||
(HELP "Unrecognized git-diff code " L))
|
||||
unless (STREQUAL ".git/" (SUBSTRING FN 1 5)))
|
||||
T])
|
||||
|
||||
(GIT-COMMIT-DIFFS
|
||||
@@ -1201,20 +1211,20 @@
|
||||
((MAIN (GIT-MAINBRANCH PROJECT)))
|
||||
(CL:WHEN STRIPWHERE
|
||||
(SETQ MAIN (STRIPWHERE MAIN)))
|
||||
(FOR DTAIL D1 MORE1 MORE2 SUPERSETS EQUALS
|
||||
ON (FOR B IN BRANCHES COLLECT (CL:WHEN STRIPWHERE
|
||||
(for DTAIL D1 MORE1 MORE2 SUPERSETS EQUALS
|
||||
on (for B in BRANCHES collect (CL:WHEN STRIPWHERE
|
||||
(SETQ B (STRIPWHERE B)))
|
||||
(CONS B (GIT-COMMIT-DIFFS B MAIN PROJECT)))
|
||||
DO
|
||||
do
|
||||
(* ;; "For each branch we now have the list of commit identifiers (hexstrings) that they do not share with the main branch.")
|
||||
|
||||
(SETQ D1 (CAR DTAIL))
|
||||
[FOR D2 IN (CDR DTAIL)
|
||||
DO (CL:WHEN (EQUAL (CDR D1)
|
||||
[for D2 in (CDR DTAIL)
|
||||
do (CL:WHEN (EQUAL (CDR D1)
|
||||
(CDR D2)) (* ; "Unlikely")
|
||||
(PUSH [CDR (OR (ASSOC (CAR D1)
|
||||
(push [CDR (OR (ASSOC (CAR D1)
|
||||
EQUALS)
|
||||
(CAR (PUSH EQUALS (CONS (CAR D1]
|
||||
(CAR (push EQUALS (CONS (CAR D1]
|
||||
(CAR D2))
|
||||
(GO $$ITERATE))
|
||||
(SETQ MORE2 (MEMBER (CADR D1)
|
||||
@@ -1222,33 +1232,33 @@
|
||||
"The most recent commit of D1 is in D2")
|
||||
(SETQ MORE1 (MEMBER (CADR D2)
|
||||
(CDR D1)))
|
||||
(IF MORE2
|
||||
THEN (CL:UNLESS MORE1
|
||||
(PUSH [CDR (OR (ASSOC (CAR D2)
|
||||
(if MORE2
|
||||
then (CL:UNLESS MORE1
|
||||
(push [CDR (OR (ASSOC (CAR D2)
|
||||
SUPERSETS)
|
||||
(CAR (PUSH SUPERSETS (CONS (CAR D2]
|
||||
(CAR (push SUPERSETS (CONS (CAR D2]
|
||||
(CAR D1)))
|
||||
ELSEIF MORE1
|
||||
THEN (PUSH [CDR (OR (ASSOC (CAR D1)
|
||||
elseif MORE1
|
||||
then (push [CDR (OR (ASSOC (CAR D1)
|
||||
SUPERSETS)
|
||||
(CAR (PUSH SUPERSETS (CONS (CAR D1]
|
||||
(CAR (push SUPERSETS (CONS (CAR D1]
|
||||
(CAR D2]
|
||||
FINALLY
|
||||
finally
|
||||
|
||||
(* ;; "Sort the supersets so that the larger ones come before the smaller ones")
|
||||
|
||||
(CL:WHEN STRIPWHERE
|
||||
[SETQ SUPERSETS (FOR S IN SUPERSETS COLLECT (FOR SS IN S COLLECT (STRIPWHERE SS]
|
||||
[SETQ EQUALS (FOR S IN EQUALS COLLECT (FOR SS IN S COLLECT (STRIPWHERE SS])
|
||||
[FOR S IN SUPERSETS
|
||||
DO (CHANGE (CDR S)
|
||||
[SETQ SUPERSETS (for S in SUPERSETS collect (for SS in S collect (STRIPWHERE SS]
|
||||
[SETQ EQUALS (for S in EQUALS collect (for SS in S collect (STRIPWHERE SS])
|
||||
[for S in SUPERSETS
|
||||
do (change (CDR S)
|
||||
(SORT DATUM (FUNCTION (LAMBDA (B1 B2)
|
||||
(OR (MEMB B2 (CDR (ASSOC B1 SUPERSETS)))
|
||||
(NOT (MEMB B1 (CDR (ASSOC B2 SUPERSETS]
|
||||
[FOR E IN EQUALS DO (CHANGE (CDR E)
|
||||
(IF (MEMB MAIN (CDR E))
|
||||
THEN (CONS MAIN (DREMOVE MAIN (SORT DATUM)))
|
||||
ELSE (SORT DATUM]
|
||||
[for E in EQUALS do (change (CDR E)
|
||||
(if (MEMB MAIN (CDR E))
|
||||
then (CONS MAIN (DREMOVE MAIN (SORT DATUM)))
|
||||
else (SORT DATUM]
|
||||
(RETURN (LIST SUPERSETS EQUALS])
|
||||
)
|
||||
|
||||
@@ -1277,14 +1287,15 @@
|
||||
0])])
|
||||
|
||||
(GIT-CHECKOUT
|
||||
[LAMBDA (BRANCH PROJECT) (* ; "Edited 2-May-2024 11:17 by mth")
|
||||
[LAMBDA (BRANCH PROJECT) (* ; "Edited 12-Jun-2024 22:44 by mth")
|
||||
(* ; "Edited 2-May-2024 11:17 by mth")
|
||||
(* ; "Edited 7-Jul-2022 20:21 by rmk")
|
||||
(* ; "Edited 9-May-2022 15:12 by rmk")
|
||||
(* ; "Edited 7-May-2022 23:51 by rmk")
|
||||
(* ; "Edited 2-Nov-2021 22:40 by rmk:")
|
||||
(CL:UNLESS BRANCH
|
||||
(SETQ BRANCH (GIT-MAINBRANCH PROJECT)))
|
||||
(LET ((CURRENTBRANCH (GIT-WHICH-BRANCH PROJECT)))
|
||||
(LET ((CURRENTBRANCH (GIT-WHICH-BRANCH PROJECT T)))
|
||||
[SETQ CURRENTBRANCH (SUBSTRING CURRENTBRANCH (ADD1 (STRPOS "/" CURRENTBRANCH]
|
||||
(CL:UNLESS [STRING.EQUAL CURRENTBRANCH (SUBSTRING BRANCH (ADD1 (OR (STRPOS "/" BRANCH)
|
||||
0]
|
||||
@@ -1295,14 +1306,16 @@
|
||||
BRANCH])
|
||||
|
||||
(GIT-WHICH-BRANCH
|
||||
[LAMBDA (PROJECT) (* ; "Edited 7-May-2022 22:41 by rmk")
|
||||
[LAMBDA (PROJECT ALL) (* ; "Edited 12-Jun-2024 12:57 by mth")
|
||||
(* ; "Edited 7-May-2022 22:41 by rmk")
|
||||
|
||||
(* ;; "Returns the current (local) branch in PROJECT")
|
||||
|
||||
(MKATOM (CONCAT "local/" (CAR (GIT-COMMAND "git rev-parse --abbrev-ref HEAD" NIL NIL PROJECT])
|
||||
(MKATOM (CONCAT "local/" (CAR (GIT-COMMAND "git rev-parse --abbrev-ref HEAD" ALL NIL PROJECT])
|
||||
|
||||
(GIT-MAKE-BRANCH
|
||||
[LAMBDA (NAME TITLESTRING PROJECT) (* ; "Edited 2-May-2024 11:24 by mth")
|
||||
[LAMBDA (NAME TITLESTRING PROJECT) (* ; "Edited 12-Jun-2024 22:47 by mth")
|
||||
(* ; "Edited 2-May-2024 11:24 by mth")
|
||||
(* ; "Edited 18-Jul-2022 21:45 by rmk")
|
||||
(* ; "Edited 19-May-2022 17:57 by rmk")
|
||||
(* ; "Edited 9-May-2022 15:13 by rmk")
|
||||
@@ -1320,12 +1333,14 @@
|
||||
|
||||
(* ;; "Git branch names can't contain spaces or colons")
|
||||
|
||||
(* ;; "mth: Notice that this is only dealing with spaces. There are other %"troublesome%" characters beyond colon, as well.")
|
||||
|
||||
[SETQ TITLESTRING (CONCATCODES (for I C from 1 while (SETQ C (NTHCHARCODE TITLESTRING I))
|
||||
collect (if (EQ C (CHARCODE SPACE))
|
||||
then (CHARCODE -)
|
||||
else C]
|
||||
(SETQ NAME (CONCAT NAME "--" TITLESTRING)))
|
||||
(LET ((UNDER (GIT-WHICH-BRANCH PROJECT))
|
||||
(LET ((UNDER (GIT-WHICH-BRANCH PROJECT T))
|
||||
RESULT)
|
||||
(if (EQ 'Y (ASKUSER NIL 'N (CONCAT "Branch " NAME " will be created under " UNDER
|
||||
". Is that OK? ")))
|
||||
@@ -1343,7 +1358,8 @@
|
||||
NIL])
|
||||
|
||||
(GIT-BRANCHES
|
||||
[LAMBDA (WHERE PROJECT EXCLUDEMERGED) (* ; "Edited 2-May-2024 11:26 by mth")
|
||||
[LAMBDA (WHERE PROJECT EXCLUDEMERGED) (* ; "Edited 12-Jun-2024 12:46 by mth")
|
||||
(* ; "Edited 2-May-2024 11:26 by mth")
|
||||
(* ; "Edited 9-Aug-2022 10:45 by rmk")
|
||||
(* ; "Edited 18-Jul-2022 08:11 by rmk")
|
||||
(* ; "Edited 8-Jul-2022 10:33 by rmk")
|
||||
@@ -1357,12 +1373,12 @@
|
||||
|
||||
(LET ([LOCAL (CL:WHEN (MEMB (U-CASE WHERE)
|
||||
'(NIL ALL LOCAL))
|
||||
[for B in (GIT-COMMAND "git branch" NIL NIL PROJECT)
|
||||
[for B in (GIT-COMMAND "git branch" T NIL PROJECT)
|
||||
collect (SUBATOM B 3 (SUB1 (OR (STRPOS " -> " B)
|
||||
0])]
|
||||
[REMOTE (CL:WHEN (MEMB (U-CASE WHERE)
|
||||
'(NIL ALL REMOTE T))
|
||||
[for B in (GIT-COMMAND "git branch -r" NIL NIL PROJECT)
|
||||
[for B in (GIT-COMMAND "git branch -r" T NIL PROJECT)
|
||||
collect (SUBATOM B 3 (SUB1 (OR (STRPOS " -> " B)
|
||||
0])]
|
||||
BRANCHES)
|
||||
@@ -1408,7 +1424,7 @@
|
||||
(CL:WHEN (SETQ BRANCHES (MKLIST BRANCHES))
|
||||
(CL:WHEN PIN?
|
||||
[SETQ BRANCHES (APPEND BRANCHES '((" Pin menu" 'PinMenu])
|
||||
(CREATE MENU
|
||||
(create MENU
|
||||
TITLE _ (OR TITLE (CONCAT (LENGTH BRANCHES)
|
||||
" branches"))
|
||||
ITEMS _ BRANCHES
|
||||
@@ -1463,13 +1479,13 @@
|
||||
(ERROR "gh must be installed in order to enumerate pull requests:"))
|
||||
(LET [(JPARSE (JSON-PARSE (CAR (GIT-COMMAND "gh pr list --json number,headRefName,title,isDraft,reviewDecision,url,headRepository,headRepositoryOwner"
|
||||
T NIL PROJECT]
|
||||
(FOR JSOBJ DRAFT PR IN (SELECTQ (CAR JPARSE)
|
||||
(for JSOBJ DRAFT PR in (SELECTQ (CAR JPARSE)
|
||||
(ARRAY (CDR JPARSE))
|
||||
(OBJECT JPARSE)
|
||||
(ERROR "UNRECOGNIZED PRC LIST FROM GIT" JPARSE))
|
||||
EACHTIME [SETQ DRAFT (EQ 'true (JSON-GET JSOBJ 'isDraft] WHEN (OR INCLUDEDRAFTS
|
||||
eachtime [SETQ DRAFT (EQ 'true (JSON-GET JSOBJ 'isDraft] when (OR INCLUDEDRAFTS
|
||||
(NOT DRAFT))
|
||||
COLLECT [SETQ PR (CREATE PULLREQUEST
|
||||
collect [SETQ PR (create PULLREQUEST
|
||||
PRNUMBER _ (JSON-GET JSOBJ 'number)
|
||||
PRNAME _ (JSON-GET JSOBJ 'headRefName)
|
||||
PRDESCRIPTION _ (JSON-GET JSOBJ 'title)
|
||||
@@ -1529,28 +1545,28 @@
|
||||
(CL:UNLESS PRS
|
||||
(SETQ PRS (GIT-PULL-REQUESTS T PROJECT)))
|
||||
(CL:WHEN PRS
|
||||
(LET ((RELATIONS (GIT-BRANCH-RELATIONS (FOR PR IN PRS
|
||||
COLLECT (GITORIGIN (fetch PRNAME of PR)))
|
||||
(LET ((RELATIONS (GIT-BRANCH-RELATIONS (for PR in PRS
|
||||
collect (GITORIGIN (fetch PRNAME of PR)))
|
||||
NIL T PROJECT)))
|
||||
(SORT (FOR PR REL LABEL PRNAME STATUS (SUPERSETS _ (CAR RELATIONS))
|
||||
(EQUALS _ (CADR RELATIONS)) IN PRS
|
||||
EACHTIME (SETQ PRNAME (fetch PRNAME of PR))
|
||||
(SORT (for PR REL LABEL PRNAME STATUS (SUPERSETS _ (CAR RELATIONS))
|
||||
(EQUALS _ (CADR RELATIONS)) in PRS
|
||||
eachtime (SETQ PRNAME (fetch PRNAME of PR))
|
||||
(SETQ LABEL (CONCAT "#" (fetch (PULLREQUEST PRNUMBER) of PR)
|
||||
" "
|
||||
(IF [SETQ REL (CAR (CDR (SASSOC PRNAME SUPERSETS]
|
||||
THEN (CONCAT PRNAME " > " REL)
|
||||
ELSEIF [SETQ REL (CAR (CDR (SASSOC PRNAME EQUALS]
|
||||
THEN (CONCAT PRNAME " = " REL)
|
||||
ELSE PRNAME)))
|
||||
(SETQ STATUS (FETCH PRSTATUS OF PR))
|
||||
WHEN (SELECTQ DRAFT
|
||||
(if [SETQ REL (CAR (CDR (SASSOC PRNAME SUPERSETS]
|
||||
then (CONCAT PRNAME " > " REL)
|
||||
elseif [SETQ REL (CAR (CDR (SASSOC PRNAME EQUALS]
|
||||
then (CONCAT PRNAME " = " REL)
|
||||
else PRNAME)))
|
||||
(SETQ STATUS (fetch PRSTATUS of PR))
|
||||
when (SELECTQ DRAFT
|
||||
(DRAFTS (EQ STATUS 'D))
|
||||
(NODRAFTS (NEQ STATUS 'D))
|
||||
T) COLLECT (LIST (CONCAT " " STATUS " " LABEL)
|
||||
T) collect (LIST (CONCAT " " STATUS " " LABEL)
|
||||
(GITORIGIN PRNAME)
|
||||
(CONCAT " " STATUS " #" (FETCH PRNUMBER OF PR)
|
||||
(CONCAT " " STATUS " #" (fetch PRNUMBER of PR)
|
||||
" "
|
||||
(FETCH PRDESCRIPTION OF PR))
|
||||
(fetch PRDESCRIPTION of PR))
|
||||
NIL PR))
|
||||
T)))])
|
||||
)
|
||||
@@ -1569,14 +1585,15 @@
|
||||
0])
|
||||
|
||||
(GIT-MY-BRANCHP
|
||||
[LAMBDA (BRANCH PROJECT) (* ; "Edited 19-May-2022 17:44 by rmk")
|
||||
[LAMBDA (BRANCH PROJECT) (* ; "Edited 12-Jun-2024 22:48 by mth")
|
||||
(* ; "Edited 19-May-2022 17:44 by rmk")
|
||||
(* ; "Edited 19-Jan-2022 13:22 by rmk")
|
||||
|
||||
(* ;; "Returns n if BRANCH is INITIALSn (local or origin), possibly followed by a trailing comment after hyphen.")
|
||||
|
||||
(CL:UNLESS BRANCH
|
||||
(SETQ BRANCH (GIT-WHICH-BRANCH PROJECT)))
|
||||
(GIT-BRANCH-NUM (OR BRANCH (GIT-WHICH-BRANCH PROJECT])
|
||||
(SETQ BRANCH (GIT-WHICH-BRANCH PROJECT T)))
|
||||
(GIT-BRANCH-NUM (OR BRANCH (GIT-WHICH-BRANCH PROJECT T])
|
||||
|
||||
(GIT-MY-NEXT-BRANCH
|
||||
[LAMBDA (PROJECT) (* ; "Edited 19-May-2022 14:08 by rmk")
|
||||
@@ -1726,9 +1743,9 @@
|
||||
(LET
|
||||
(MAPPINGS FROMGIT (DIFFS (GIT-BRANCH-DIFF BRANCH1 BRANCH2 PROJECT)))
|
||||
(CL:WHEN DIFFS
|
||||
(SETQ FROMGIT (PACK* '{FROMGIT (ADD FROMGITN 1)
|
||||
(SETQ FROMGIT (PACK* '{FROMGIT (add FROMGITN 1)
|
||||
'}))
|
||||
(PSEUDOHOST FROMGIT (CONCAT "{CORE}<" (FETCH PROJECTNAME OF PROJECT)
|
||||
(PSEUDOHOST FROMGIT (CONCAT "{CORE}<" (fetch PROJECTNAME of PROJECT)
|
||||
">"
|
||||
(DATE)
|
||||
">"))
|
||||
@@ -1741,8 +1758,8 @@
|
||||
(CL:UNLESS DIR2
|
||||
(SETQ DIR2 (CONCAT FROMGIT "<" (UNSLASHIT BRANCH2)
|
||||
">")))
|
||||
(FOR D IN DIFFS
|
||||
DO (SELECTQ (CAR D)
|
||||
(for D in DIFFS
|
||||
do (SELECTQ (CAR D)
|
||||
(ADDED (* ;
|
||||
"Shouldn't exist in BRANCH2, should exist in BRANCH1, but maybe ADDED and DELETED are mixed up?")
|
||||
(SETQ D (CADR D))
|
||||
@@ -1789,14 +1806,14 @@
|
||||
|
||||
(* ;; "Let the directories figure it out")
|
||||
|
||||
(AND NIL (IF (EQ (CADDR GFILE)
|
||||
(AND NIL (if (EQ (CADDR GFILE)
|
||||
100)
|
||||
THEN
|
||||
then
|
||||
|
||||
(* ;; "A little tricky to figure out what corresponds to the real file in the mapping, which directory it belongs to. Maybe the first one should always be one that exists, the second may just be a useful name. But we have to know whether to match against INFO1 or INFO2")
|
||||
|
||||
(HELP GFILE 100)
|
||||
(PUSH MAPPINGS
|
||||
(push MAPPINGS
|
||||
(LIST (LIST)
|
||||
(FULLNAME F1)
|
||||
(SLASHIT (U-CASE (CONCAT DIR2 (CAR GFILE))
|
||||
@@ -1805,7 +1822,7 @@
|
||||
(NTHCHAR (CAR D)
|
||||
1)
|
||||
100))
|
||||
ELSE
|
||||
else
|
||||
(* ;;
|
||||
"If not a perfect match, then the directory should figure it out")
|
||||
|
||||
@@ -1816,7 +1833,9 @@
|
||||
(LIST DIR1 DIR2 MAPPINGS))])
|
||||
|
||||
(GIT-BRANCHES-COMPARE-DIRECTORIES
|
||||
[LAMBDA (BRANCH1 BRANCH2 LOCAL PROJECT) (* ; "Edited 1-May-2024 14:58 by rmk")
|
||||
[LAMBDA (BRANCH1 BRANCH2 LOCAL PROJECT) (* ; "Edited 12-Jun-2024 22:52 by mth")
|
||||
(* ; "Edited 10-Jun-2024 18:42 by mth")
|
||||
(* ; "Edited 1-May-2024 14:58 by rmk")
|
||||
(* ; "Edited 26-Sep-2023 22:40 by rmk")
|
||||
(* ; "Edited 10-Jun-2023 17:28 by rmk")
|
||||
(* ; "Edited 12-Sep-2022 14:41 by rmk")
|
||||
@@ -1825,23 +1844,26 @@
|
||||
(* ; "Edited 9-May-2022 15:14 by rmk")
|
||||
(* ; "Edited 3-May-2022 23:04 by rmk")
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
(SETQ BRANCH1 (IF BRANCH1
|
||||
THEN (GITORIGIN BRANCH1 LOCAL)
|
||||
ELSE (GIT-WHICH-BRANCH PROJECT)))
|
||||
(SETQ BRANCH1 (if BRANCH1
|
||||
then (GITORIGIN BRANCH1 LOCAL)
|
||||
else (GIT-WHICH-BRANCH PROJECT T)))
|
||||
(LET (CDVALUE DIRS NENTRIES MAPPINGS (SHORT1 (GIT-SHORT-BRANCH-NAME BRANCH1))
|
||||
(SHORT2 (GIT-SHORT-BRANCH-NAME BRANCH2)))
|
||||
(PRINTOUT T "Comparing all " (L-CASE (FETCH PROJECTNAME OF PROJECT)
|
||||
(PRINTOUT T "Comparing all " (L-CASE (fetch PROJECTNAME of PROJECT)
|
||||
T)
|
||||
" subdirectories of " SHORT1 " and " SHORT2 T)
|
||||
(PRINTOUT T "Fetching differences" T)
|
||||
(SETQ DIRS (GIT-GET-DIFFERENT-FILES BRANCH1 BRANCH2 NIL NIL PROJECT))
|
||||
(SETQ MAPPINGS (CADDR DIRS))
|
||||
(IF DIRS
|
||||
THEN (TERPRI T)
|
||||
(if DIRS
|
||||
then (TERPRI T)
|
||||
|
||||
(* ;; "INCLUDEDFILES parameter to COMPAREDIRECTORIES needs to allow both top-level files, and leading dot filenames.")
|
||||
|
||||
[SETQ CDVALUE (COMPAREDIRECTORIES (CAR DIRS)
|
||||
(CADR DIRS)
|
||||
'(> < ~= -* *-)
|
||||
'*>*.*
|
||||
'(*.* *>*.* .* *>.*)
|
||||
(GIT-GET-PROJECT PROJECT 'EXCLUSIONS)
|
||||
NIL NIL NIL NIL (LIST (PACKFILENAME 'HOST NIL 'BODY
|
||||
(CAR DIRS))
|
||||
@@ -1857,30 +1879,30 @@
|
||||
(FUNCTION (LAMBDA (CDE)
|
||||
(DECLARE (USEDFREE INFO1 INFO2))
|
||||
(LET [(MAP (CL:UNLESS INFO2
|
||||
(FIND M IN MAPPINGS
|
||||
SUCHTHAT (STRING.EQUAL (CAR M)
|
||||
(FETCH (CDINFO FULLNAME)
|
||||
OF INFO1)
|
||||
(find M in MAPPINGS
|
||||
suchthat (STRING.EQUAL (CAR M)
|
||||
(fetch (CDINFO FULLNAME)
|
||||
of INFO1)
|
||||
FILEDIRCASEARRAY)))]
|
||||
(CL:WHEN MAP
|
||||
(HELP 'MAP MAP))
|
||||
(CL:WHEN INFO1
|
||||
(CHANGE (FETCH (CDINFO FULLNAME) OF INFO1)
|
||||
(change (fetch (CDINFO FULLNAME) of INFO1)
|
||||
(SLASHIT (PACKFILENAME.STRING 'VERSION NIL
|
||||
'BODY DATUM)
|
||||
T)))
|
||||
(CL:WHEN INFO2
|
||||
(CHANGE (FETCH (CDINFO FULLNAME) OF INFO2)
|
||||
(change (fetch (CDINFO FULLNAME) of INFO2)
|
||||
(SLASHIT (PACKFILENAME.STRING 'VERSION NIL
|
||||
'BODY DATUM)
|
||||
T)))
|
||||
(IF MAP
|
||||
THEN
|
||||
(if MAP
|
||||
then
|
||||
|
||||
(* ;; "This handles renames and copies. We want the nominal source of a rename to be in the first column, even though the target location is the one that was fetched.")
|
||||
|
||||
(REPLACE (CDENTRY INFO2) OF CDE
|
||||
WITH (CREATE CDINFO
|
||||
(replace (CDENTRY INFO2) of CDE
|
||||
with (create CDINFO
|
||||
FULLNAME _ (CADR MAP)
|
||||
DATE _ (CL:IF (EQ 'R (CADDR MAP))
|
||||
" <-"
|
||||
@@ -1889,31 +1911,33 @@
|
||||
AUTHOR _ ""
|
||||
TYPE _ ""
|
||||
EOL _ ""))
|
||||
(REPLACE (CDENTRY DATEREL) OF CDE
|
||||
WITH (CADDR MAP]
|
||||
(replace (CDENTRY DATEREL) of CDE
|
||||
with (CADDR MAP]
|
||||
(TERPRI T)
|
||||
(IF (FETCH (CDVALUE CDENTRIES) OF CDVALUE)
|
||||
THEN (SETQ LAST-BRANCH-CDVALUE CDVALUE)
|
||||
(CDBROWSER CDVALUE (CONCAT (L-CASE (FETCH PROJECTNAME OF PROJECT)
|
||||
(if (fetch (CDVALUE CDENTRIES) of CDVALUE)
|
||||
then (SETQ LAST-BRANCH-CDVALUE CDVALUE)
|
||||
(CDBROWSER CDVALUE (CONCAT (L-CASE (fetch PROJECTNAME of PROJECT)
|
||||
T)
|
||||
" " SHORT1 " vs " SHORT2 " "
|
||||
(LENGTH (FETCH (CDVALUE CDENTRIES) OF CDVALUE))
|
||||
(LENGTH (fetch (CDVALUE CDENTRIES) of CDVALUE))
|
||||
" files")
|
||||
(LIST SHORT1 SHORT2)
|
||||
`(LABELFN GIT-CD-LABELFN BRANCH1 ,BRANCH1 BRANCH2 ,BRANCH2 PROJECT
|
||||
,PROJECT)
|
||||
GIT-CDBROWSER-SEPARATE-DIRECTIONS
|
||||
`(Compare See))
|
||||
(SETQ NENTRIES (LENGTH (FETCH (CDVALUE CDENTRIES) OF CDVALUE)))
|
||||
(SETQ NENTRIES (LENGTH (fetch (CDVALUE CDENTRIES) of CDVALUE)))
|
||||
(LIST NENTRIES (CL:IF (EQ NENTRIES 1)
|
||||
'difference
|
||||
'differences))
|
||||
ELSE '(0 differences))
|
||||
ELSE '(0 differences])
|
||||
else '(0 differences))
|
||||
else '(0 differences])
|
||||
|
||||
(GIT-WORKING-COMPARE-DIRECTORIES
|
||||
[LAMBDA (SUBDIRS SELECT EXCLUDEDFILES FIXDIRECTORYDATES UPDATE PROJECT)
|
||||
|
||||
(* ;; "Edited 12-Jun-2024 22:52 by mth")
|
||||
|
||||
(* ;; "Edited 26-Sep-2023 22:41 by rmk")
|
||||
|
||||
(* ;; "Edited 17-Jun-2023 22:54 by rmk")
|
||||
@@ -1933,28 +1957,28 @@
|
||||
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
(CL:WHEN UPDATE (GIT-REMOTE-UPDATE NIL PROJECT)) (* ; "Doesn't matter if we are looking only at local files in the current branch. We aren't fetching or checking out.")
|
||||
(CL:UNLESS (AND (FETCH GITHOST OF PROJECT)
|
||||
(FETCH WHOST OF PROJECT))
|
||||
(ERROR (FETCH PROJECTNAME OF PROJECT)
|
||||
(CL:UNLESS (AND (fetch GITHOST of PROJECT)
|
||||
(fetch WHOST of PROJECT))
|
||||
(ERROR (fetch PROJECTNAME of PROJECT)
|
||||
" does not have both git and working directories"))
|
||||
(CL:WHEN (AND (LISTP SUBDIRS)
|
||||
(NULL (CDR SUBDIRS)))
|
||||
(SETQ SUBDIRS (CAR SUBDIRS)))
|
||||
(CL:UNLESS SUBDIRS
|
||||
(SETQ SUBDIRS (OR (FETCH DEFAULTSUBDIRS OF PROJECT)
|
||||
(SETQ SUBDIRS (OR (fetch DEFAULTSUBDIRS of PROJECT)
|
||||
'ALL)))
|
||||
(SETQ SUBDIRS (L-CASE SUBDIRS))
|
||||
(LET ((SUBDIRSTRING (IF (EQ SUBDIRS 'all)
|
||||
THEN (SETQ SUBDIRS (ALLSUBDIRS PROJECT))
|
||||
(LET ((SUBDIRSTRING (if (EQ SUBDIRS 'all)
|
||||
then (SETQ SUBDIRS (ALLSUBDIRS PROJECT))
|
||||
"ALL subdirectories"
|
||||
ELSE SUBDIRS)))
|
||||
(FOR SUBDIR TITLE CDVAL (WPROJ _ (CONCAT "Working " (L-CASE (FETCH PROJECTNAME OF PROJECT)
|
||||
else SUBDIRS)))
|
||||
(for SUBDIR TITLE CDVAL (WPROJ _ (CONCAT "Working " (L-CASE (fetch PROJECTNAME of PROJECT)
|
||||
T)))
|
||||
(NENTRIES _ 0)
|
||||
(BRANCH2 _ (GIT-WHICH-BRANCH PROJECT))
|
||||
FIRST (PRINTOUT T "Comparing " SUBDIRSTRING 6 " of " WPROJ " and Git " BRANCH2 T)
|
||||
(BKSYSBUF " ") INSIDE SUBDIRS
|
||||
COLLECT (TERPRI T)
|
||||
(BRANCH2 _ (GIT-WHICH-BRANCH PROJECT T))
|
||||
first (PRINTOUT T "Comparing " SUBDIRSTRING 6 " of " WPROJ " and Git " BRANCH2 T)
|
||||
(BKSYSBUF " ") inside SUBDIRS
|
||||
collect (TERPRI T)
|
||||
(SETQ CDVAL (COMPAREDIRECTORIES (MYMEDLEYSUBDIR SUBDIR T PROJECT)
|
||||
(GITSUBDIR SUBDIR T PROJECT)
|
||||
(OR SELECT '(> < ~= -* *-))
|
||||
@@ -1967,24 +1991,24 @@
|
||||
(SUBSTRING E (ADD1 DPOS))
|
||||
E))
|
||||
NIL NIL NIL FIXDIRECTORYDATES))
|
||||
[FOR CDE IN (FETCH CDENTRIES OF CDVAL)
|
||||
DO (CL:WHEN (FETCH INFO1 OF CDE)
|
||||
(CHANGE (FETCH (CDINFO FULLNAME) OF (FETCH INFO1 OF CDE))
|
||||
[for CDE in (fetch CDENTRIES of CDVAL)
|
||||
do (CL:WHEN (fetch INFO1 of CDE)
|
||||
(change (fetch (CDINFO FULLNAME) of (fetch INFO1 of CDE))
|
||||
(UNSLASHIT DATUM T)))
|
||||
(CL:WHEN (FETCH INFO2 OF CDE)
|
||||
(CHANGE (FETCH (CDINFO FULLNAME) OF (FETCH INFO2 OF CDE))
|
||||
(CL:WHEN (fetch INFO2 of CDE)
|
||||
(change (fetch (CDINFO FULLNAME) of (fetch INFO2 of CDE))
|
||||
(SLASHIT DATUM T)))]
|
||||
CDVAL
|
||||
FINALLY
|
||||
finally
|
||||
|
||||
(* ;; "Set up the browsers after everything has been done, otherwise if the user doesn't pay attention it might hang waiting for a region.")
|
||||
|
||||
(CL:WHEN (AND (CDR $$VAL)
|
||||
GIT-MERGE-COMPARES)
|
||||
(SETQ $$VAL (CDMERGE $$VAL))
|
||||
[SETQ SUBDIRS (CONCATLIST (FOR SUBDIR IN SUBDIRS COLLECT (CONCAT SUBDIR " "])
|
||||
[FOR CDVAL TITLE IN $$VAL AS SUBDIR INSIDE SUBDIRS
|
||||
DO (SETQ TITLE (CONCAT WPROJ " vs. " BRANCH2 " " SUBDIR " "
|
||||
[SETQ SUBDIRS (CONCATLIST (for SUBDIR in SUBDIRS collect (CONCAT SUBDIR " "])
|
||||
[for CDVAL TITLE in $$VAL as SUBDIR inside SUBDIRS
|
||||
do (SETQ TITLE (CONCAT WPROJ " vs. " BRANCH2 " " SUBDIR " "
|
||||
(LENGTH (fetch (CDVALUE CDENTRIES) of CDVAL))
|
||||
" files"))
|
||||
[CDBROWSER CDVAL TITLE `(,WPROJ ,BRANCH2)
|
||||
@@ -1995,9 +2019,9 @@
|
||||
,@(CL:UNLESS (GIT-MAINBRANCH? BRANCH2 PROJECT T)
|
||||
'("" Copy% -> (Delete% -> GIT-CD-MENUFN)))]
|
||||
(CONS (CONCAT SUBDIR "/")
|
||||
(FOR CDENTRY IN (fetch CDENTRIES of CDVAL)
|
||||
COLLECT (fetch MATCHNAME of CDENTRY)))
|
||||
(ADD NENTRIES (LENGTH (FETCH (CDVALUE CDENTRIES) OF CDVAL]
|
||||
(for CDENTRY in (fetch CDENTRIES of CDVAL)
|
||||
collect (fetch MATCHNAME of CDENTRY)))
|
||||
(add NENTRIES (LENGTH (fetch (CDVALUE CDENTRIES) of CDVAL]
|
||||
(SETQ LAST-WMEDLEY-CDVALUES $$VAL)
|
||||
(TERPRI T)
|
||||
(RETURN (LIST NENTRIES (CL:IF (EQ NENTRIES 1)
|
||||
@@ -2264,7 +2288,7 @@
|
||||
(* ; "Edited 7-Jul-2022 09:36 by rmk")
|
||||
(* ; "Edited 7-May-2022 22:41 by rmk")
|
||||
(* ; "Edited 2-Nov-2021 21:12 by rmk:")
|
||||
(CONCAT "cd " (SLASHIT (TRUEFILENAME (FETCH GITHOST OF PROJECT))
|
||||
(CONCAT "cd " (SLASHIT (TRUEFILENAME (fetch GITHOST of PROJECT))
|
||||
NIL T)
|
||||
" && "])
|
||||
|
||||
@@ -2280,8 +2304,8 @@
|
||||
(CL:UNLESS (OR (EQ 1 (STRPOS "git" CMD))
|
||||
(EQ 1 (STRPOS "gh" CMD)))
|
||||
(SETQ CMD (CONCAT "git " CMD)))
|
||||
[BIND LPOS WHILE (SETQ LPOS (STRPOS "local/" CMD))
|
||||
DO (SETQ CMD (CONCAT (SUBSTRING CMD 1 (SUB1 LPOS))
|
||||
[bind LPOS while (SETQ LPOS (STRPOS "local/" CMD))
|
||||
do (SETQ CMD (CONCAT (SUBSTRING CMD 1 (SUB1 LPOS))
|
||||
(SUBSTRING CMD (IPLUS LPOS (NCHARS "local/"]
|
||||
(LET (LINES (RESULTFILE (GIT-COMMAND-TO-FILE CMD PROJECT NOERROR)))
|
||||
(CL:WHEN (LISTP RESULTFILE) (* ; "CADR is Unix error stream")
|
||||
@@ -2303,10 +2327,10 @@
|
||||
(* ;; "Insures origin/ unless LOCAL or local/ already")
|
||||
|
||||
(CL:UNLESS BRANCH (HELP "BRANCH MUST BE SPECIFIED"))
|
||||
(IF (OR (STRPOS "origin/" BRANCH)
|
||||
(if (OR (STRPOS "origin/" BRANCH)
|
||||
(STRPOS "local/" BRANCH))
|
||||
THEN BRANCH
|
||||
ELSE (CONCAT (CL:IF LOCAL
|
||||
then BRANCH
|
||||
else (CONCAT (CL:IF LOCAL
|
||||
"local/"
|
||||
"origin/")
|
||||
BRANCH])
|
||||
@@ -2338,7 +2362,7 @@
|
||||
(RESULTFILE (CONCAT "{UNIX}/tmp/" PROJECTNAME "-" DATE "-" RAND "-result"))
|
||||
(ERRORFILE (CONCAT "{UNIX}/tmp/" PROJECTNAME "-" DATE "-" RAND "-error"))
|
||||
COMPLETIONCODE)
|
||||
[SETQ COMPLETIONCODE (PROCESS-COMMAND (CONCAT (CDGITDIR PROJECT)
|
||||
[SETQ COMPLETIONCODE (PROCESS-COMMAND (CONCAT (CDGITDIR PROJECT)
|
||||
CMD " > " (STRIPHOST RESULTFILE)
|
||||
" 2> "
|
||||
(STRIPHOST ERRORFILE]
|
||||
@@ -2365,12 +2389,12 @@
|
||||
(FILEPOS "unknown command %"" ESTREAM 0 1)))
|
||||
(FILEPOS "' is not a git command." ESTREAM (NCHARS CMD)))
|
||||
(SETQ COMPLETIONCODE 1))))
|
||||
(IF (EQ 0 COMPLETIONCODE)
|
||||
THEN (IF (AND RESULTFILE ERRORFILE)
|
||||
THEN (LIST RESULTFILE ERRORFILE)
|
||||
ELSEIF RESULTFILE
|
||||
ELSE ERRORFILE)
|
||||
ELSE (DELFILE RESULTFILE)
|
||||
(if (EQ 0 COMPLETIONCODE)
|
||||
then (if (AND RESULTFILE ERRORFILE)
|
||||
then (LIST RESULTFILE ERRORFILE)
|
||||
elseif RESULTFILE
|
||||
else ERRORFILE)
|
||||
else (DELFILE RESULTFILE)
|
||||
(DELFILE ERRORFILE)
|
||||
(CL:UNLESS NOERROR
|
||||
(ERROR (CONCAT "Command failed: " CMD)))
|
||||
@@ -2382,18 +2406,18 @@
|
||||
(* ;; "Suppress .git lines unless ALL")
|
||||
|
||||
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :EXTERNAL-FORMAT (SYSTEM-EXTERNALFORMAT))
|
||||
(BIND LINE UNTIL (EOFP STREAM) WHEN [PROGN (SETQ LINE (CL:READ-LINE STREAM :EOF-ERROR-P
|
||||
(bind LINE until (EOFP STREAM) when [PROGN (SETQ LINE (CL:READ-LINE STREAM :EOF-ERROR-P
|
||||
NIL :EOF-VALUE NIL))
|
||||
(OR ALL (NOT (STRPOS ".git" LINE 1]
|
||||
COLLECT LINE])
|
||||
collect LINE])
|
||||
|
||||
(STRIPLOCAL
|
||||
[LAMBDA (STRING) (* ; "Edited 18-Jul-2022 09:52 by rmk")
|
||||
|
||||
(* ;; "Removes local/ substrings wherever they appear. To be used in coerecing from a lisp internal convention that local branches carry a local tag to the git convention that an unqualified name is local.")
|
||||
|
||||
[BIND POS WHILE (SETQ POS (STRPOS "local/" STRING))
|
||||
DO (SETQ STRING (CONCAT (SUBSTRING STRING 1 (SUB1 POS))
|
||||
[bind POS while (SETQ POS (STRPOS "local/" STRING))
|
||||
do (SETQ STRING (CONCAT (SUBSTRING STRING 1 (SUB1 POS))
|
||||
(OR (SUBSTRING STRING (IPLUS POS (CONSTANT (NCHARS "local/")))
|
||||
-1)
|
||||
""]
|
||||
@@ -2402,33 +2426,33 @@
|
||||
|
||||
(PUTPROPS GITFNS FILETYPE :TCOMPL)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4187 20766 (GIT-CLONEP 4197 . 5525) (GIT-INIT 5527 . 6157) (GIT-MAKE-PROJECT 6159 .
|
||||
13824) (GIT-GET-PROJECT 13826 . 15751) (GIT-PUT-PROJECT-FIELD 15753 . 17394) (GIT-PROJECT-PATH 17396
|
||||
. 18440) (FIND-ANCESTOR-DIRECTORY 18442 . 18791) (GIT-FIND-CLONE 18793 . 19874) (GIT-MAINBRANCH 19876
|
||||
. 20271) (GIT-MAINBRANCH? 20273 . 20764)) (26229 30851 (PRC-COMMAND 26239 . 30849)) (30907 33695 (
|
||||
ALLSUBDIRS 30917 . 32203) (MEDLEYSUBDIRS 32205 . 32898) (GITSUBDIRS 32900 . 33693)) (33696 38486 (
|
||||
TOGIT 33706 . 35112) (FROMGIT 35114 . 36095) (GIT-DELETE-FILE 36097 . 36943) (MYMEDLEY-DELETE-FILES
|
||||
36945 . 38484)) (38487 41490 (MYMEDLEYSUBDIR 38497 . 38953) (GITSUBDIR 38955 . 39398) (STRIPDIR 39400
|
||||
. 39771) (STRIPHOST 39773 . 40013) (STRIPNAME 40015 . 40768) (STRIPWHERE 40770 . 41488)) (41491 43393
|
||||
(GFILE4MFILE 41501 . 41864) (MFILE4GFILE 41866 . 42435) (GIT-REPO-FILENAME 42437 . 43391)) (43442
|
||||
53693 (GIT-COMMIT 43452 . 44278) (GIT-PUSH 44280 . 45040) (GIT-PULL 45042 . 45794) (GIT-APPROVAL 45796
|
||||
. 46145) (GIT-GET-FILE 46147 . 48169) (GIT-FILE-EXISTS? 48171 . 48445) (GIT-REMOTE-UPDATE 48447 .
|
||||
49171) (GIT-REMOTE-ADD 49173 . 49480) (GIT-FILE-DATE 49482 . 50529) (GIT-FILE-HISTORY 50531 . 52465) (
|
||||
GIT-PRINT-FILE-HISTORY 52467 . 53517) (GIT-FETCH 53519 . 53691)) (53723 64496 (GIT-BRANCH-DIFF 53733
|
||||
. 60133) (GIT-COMMIT-DIFFS 60135 . 60808) (GIT-BRANCH-RELATIONS 60810 . 64494)) (64541 82978 (
|
||||
GIT-BRANCH-NUM 64551 . 65124) (GIT-CHECKOUT 65126 . 66301) (GIT-WHICH-BRANCH 66303 . 66601) (
|
||||
GIT-MAKE-BRANCH 66603 . 68932) (GIT-BRANCHES 68934 . 71424) (GIT-BRANCH-EXISTS? 71426 . 72297) (
|
||||
GIT-PICK-BRANCH 72299 . 72789) (GIT-BRANCH-MENU 72791 . 73672) (GIT-BRANCH-WHENSELECTEDFN 73674 .
|
||||
75839) (GIT-PULL-REQUESTS 75841 . 79359) (GIT-SHORT-BRANCH-NAME 79361 . 79652) (GIT-LONG-NAME 79654 .
|
||||
79971) (GIT-PRC-BRANCHES 79973 . 82976)) (83008 86343 (GIT-MY-CURRENT-BRANCH 83018 . 83388) (
|
||||
GIT-MY-BRANCHP 83390 . 83895) (GIT-MY-NEXT-BRANCH 83897 . 84391) (GIT-MY-BRANCHES 84393 . 86341)) (
|
||||
86389 90464 (GIT-ADD-WORKTREE 86399 . 88006) (GIT-REMOVE-WORKTREE 88008 . 88938) (GIT-LIST-WORKTREES
|
||||
88940 . 89744) (WORKTREEDIR 89746 . 90462)) (90512 123216 (GIT-GET-DIFFERENT-FILES 90522 . 96946) (
|
||||
GIT-BRANCHES-COMPARE-DIRECTORIES 96948 . 103801) (GIT-WORKING-COMPARE-DIRECTORIES 103803 . 109199) (
|
||||
GIT-COMPARE-WORKTREE 109201 . 113179) (GITCDOBJBUTTONFN 113181 . 117671) (GIT-CD-LABELFN 117673 .
|
||||
118755) (GIT-CD-MENUFN 118757 . 121197) (GIT-WORKING-COMPARE-FILES 121199 . 121819) (
|
||||
GIT-BRANCHES-COMPARE-FILES 121821 . 122985) (GIT-PR-COMPARE 122987 . 123214)) (123286 131315 (CDGITDIR
|
||||
123296 . 123983) (GIT-COMMAND 123985 . 125543) (GITORIGIN 125545 . 126242) (GIT-INITIALS 126244 .
|
||||
126548) (GIT-COMMAND-TO-FILE 126550 . 130039) (GIT-RESULT-TO-LINES 130041 . 130648) (STRIPLOCAL 130650
|
||||
. 131313)))))
|
||||
(FILEMAP (NIL (4636 21215 (GIT-CLONEP 4646 . 5974) (GIT-INIT 5976 . 6606) (GIT-MAKE-PROJECT 6608 .
|
||||
14273) (GIT-GET-PROJECT 14275 . 16200) (GIT-PUT-PROJECT-FIELD 16202 . 17843) (GIT-PROJECT-PATH 17845
|
||||
. 18889) (FIND-ANCESTOR-DIRECTORY 18891 . 19240) (GIT-FIND-CLONE 19242 . 20323) (GIT-MAINBRANCH 20325
|
||||
. 20720) (GIT-MAINBRANCH? 20722 . 21213)) (26678 31300 (PRC-COMMAND 26688 . 31298)) (31356 34144 (
|
||||
ALLSUBDIRS 31366 . 32652) (MEDLEYSUBDIRS 32654 . 33347) (GITSUBDIRS 33349 . 34142)) (34145 38935 (
|
||||
TOGIT 34155 . 35561) (FROMGIT 35563 . 36544) (GIT-DELETE-FILE 36546 . 37392) (MYMEDLEY-DELETE-FILES
|
||||
37394 . 38933)) (38936 41939 (MYMEDLEYSUBDIR 38946 . 39402) (GITSUBDIR 39404 . 39847) (STRIPDIR 39849
|
||||
. 40220) (STRIPHOST 40222 . 40462) (STRIPNAME 40464 . 41217) (STRIPWHERE 41219 . 41937)) (41940 43842
|
||||
(GFILE4MFILE 41950 . 42313) (MFILE4GFILE 42315 . 42884) (GIT-REPO-FILENAME 42886 . 43840)) (43891
|
||||
54253 (GIT-COMMIT 43901 . 44727) (GIT-PUSH 44729 . 45489) (GIT-PULL 45491 . 46243) (GIT-APPROVAL 46245
|
||||
. 46594) (GIT-GET-FILE 46596 . 48618) (GIT-FILE-EXISTS? 48620 . 48894) (GIT-REMOTE-UPDATE 48896 .
|
||||
49731) (GIT-REMOTE-ADD 49733 . 50040) (GIT-FILE-DATE 50042 . 51089) (GIT-FILE-HISTORY 51091 . 53025) (
|
||||
GIT-PRINT-FILE-HISTORY 53027 . 54077) (GIT-FETCH 54079 . 54251)) (54283 65403 (GIT-BRANCH-DIFF 54293
|
||||
. 61040) (GIT-COMMIT-DIFFS 61042 . 61715) (GIT-BRANCH-RELATIONS 61717 . 65401)) (65448 84460 (
|
||||
GIT-BRANCH-NUM 65458 . 66031) (GIT-CHECKOUT 66033 . 67319) (GIT-WHICH-BRANCH 67321 . 67728) (
|
||||
GIT-MAKE-BRANCH 67730 . 70309) (GIT-BRANCHES 70311 . 72906) (GIT-BRANCH-EXISTS? 72908 . 73779) (
|
||||
GIT-PICK-BRANCH 73781 . 74271) (GIT-BRANCH-MENU 74273 . 75154) (GIT-BRANCH-WHENSELECTEDFN 75156 .
|
||||
77321) (GIT-PULL-REQUESTS 77323 . 80841) (GIT-SHORT-BRANCH-NAME 80843 . 81134) (GIT-LONG-NAME 81136 .
|
||||
81453) (GIT-PRC-BRANCHES 81455 . 84458)) (84490 87938 (GIT-MY-CURRENT-BRANCH 84500 . 84870) (
|
||||
GIT-MY-BRANCHP 84872 . 85490) (GIT-MY-NEXT-BRANCH 85492 . 85986) (GIT-MY-BRANCHES 85988 . 87936)) (
|
||||
87984 92059 (GIT-ADD-WORKTREE 87994 . 89601) (GIT-REMOVE-WORKTREE 89603 . 90533) (GIT-LIST-WORKTREES
|
||||
90535 . 91339) (WORKTREEDIR 91341 . 92057)) (92107 125241 (GIT-GET-DIFFERENT-FILES 92117 . 98541) (
|
||||
GIT-BRANCHES-COMPARE-DIRECTORIES 98543 . 105774) (GIT-WORKING-COMPARE-DIRECTORIES 105776 . 111224) (
|
||||
GIT-COMPARE-WORKTREE 111226 . 115204) (GITCDOBJBUTTONFN 115206 . 119696) (GIT-CD-LABELFN 119698 .
|
||||
120780) (GIT-CD-MENUFN 120782 . 123222) (GIT-WORKING-COMPARE-FILES 123224 . 123844) (
|
||||
GIT-BRANCHES-COMPARE-FILES 123846 . 125010) (GIT-PR-COMPARE 125012 . 125239)) (125311 133336 (CDGITDIR
|
||||
125321 . 126008) (GIT-COMMAND 126010 . 127568) (GITORIGIN 127570 . 128267) (GIT-INITIALS 128269 .
|
||||
128573) (GIT-COMMAND-TO-FILE 128575 . 132060) (GIT-RESULT-TO-LINES 132062 . 132669) (STRIPLOCAL 132671
|
||||
. 133334)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
193
lispusers/QIX
193
lispusers/QIX
@@ -1,13 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
(FILECREATED "24-Aug-2022 07:58:48" |{DSK}<home>larry>medley>lispusers>QIX.;2| 11276
|
||||
(FILECREATED "14-Jun-2024 14:54:24" |{WMEDLEY}<lispusers>QIX.;4| 12192
|
||||
|
||||
:CHANGES-TO (FNS QIX.IDLE)
|
||||
:EDIT-BY |rmk|
|
||||
|
||||
:PREVIOUS-DATE "12-Aug-87 03:05:50" |{DSK}<home>larry>medley>lispusers>QIX.;1|)
|
||||
:CHANGES-TO (FNS QIX.GROW)
|
||||
|
||||
:PREVIOUS-DATE "14-Jun-2024 14:49:48" |{WMEDLEY}<lispusers>QIX.;3|)
|
||||
|
||||
; Copyright (c) 1987 by Xerox Corporation.
|
||||
|
||||
(PRETTYCOMPRINT QIXCOMS)
|
||||
|
||||
@@ -18,69 +18,72 @@
|
||||
(DEFINEQ
|
||||
|
||||
(QIX.GROW
|
||||
(LAMBDA (WINDOW DONTDISMISS) (* \; "Edited 1-Aug-87 16:57 by JEFF.SHRAGER")
|
||||
|
||||
(* * |This| |sets| |up| \a QIX |the| |specified| |window.|
|
||||
|The| |QIX's| |parameters| |are| |defined| |at| |random,| |but| |with|
|
||||
|reasonable| |value| |ranges.| |The| |dismiss| |argument| |tell| |the| QIX
|
||||
|whether| |to| DISMISS |every| |cycle| |or| |not.|
|
||||
B\e |careful.|)
|
||||
(LAMBDA (WINDOW DONTDISMISS) (* \; "Edited 14-Jun-2024 14:54 by rmk")
|
||||
(* \;
|
||||
"Edited 1-Aug-87 16:57 by JEFF.SHRAGER")
|
||||
|
||||
(* |;;;| "This sets up a QIX the specified window. The QIX's parameters are defined at random, but with reasonable value ranges. The dismiss argument tell the QIX whether to DISMISS every cycle or not. Be careful.")
|
||||
|
||||
(PROG (P P2 (W (OR WINDOW (CREATEW)))
|
||||
L)
|
||||
(SETQ *STOP.QIXS* NIL)
|
||||
|
||||
(* * P |and| P2 |define| \a QIX.)
|
||||
|
||||
(* |;;;| "P and P2 define a QIX.")
|
||||
|
||||
(SETQ P (|create| QIX.POINT
|
||||
X _ (RAND 1 200)
|
||||
Y _ (RAND 1 100)
|
||||
QX _ (RAND 1 200)
|
||||
QY _ (RAND 1 100)
|
||||
VH _ (RAND 1 20)
|
||||
VV _ (RAND 1 20)))
|
||||
(SETQ P2 (|create| QIX.POINT
|
||||
X _ (RAND 1 200)
|
||||
Y _ (RAND 1 100)
|
||||
QX _ (RAND 1 200)
|
||||
QY _ (RAND 1 100)
|
||||
VH _ (RAND 1 20)
|
||||
VV _ (RAND 1 20)))
|
||||
|
||||
(* * L |is| |the| |tail| |list.| I\t |starts| |out| |full| |of| NIL\s |and|
|
||||
|gets| |filled| |as| |the| QIX |moves.| I\t |is| |also| |inserted| |in| |it's|
|
||||
|own| |mouth| |so| |that| |the| |whole| |thing| |wraps| |around.|)
|
||||
|
||||
(* |;;;| "L is the tail list. It starts out full of NILs and gets filled as the QIX moves. It is also inserted in it's own mouth so that the whole thing wraps around.")
|
||||
|
||||
(SETQ L (APPEND (|for| X |from| 1 |to| (RAND 5 25)
|
||||
|collect| (COPY '(A S D F)))
|
||||
(LIST (LIST (|fetch| X P)
|
||||
(|fetch| Y P)
|
||||
(|fetch| X P2)
|
||||
(|fetch| Y P2)))))
|
||||
(LIST (LIST (|fetch| (QIX.POINT QX)
|
||||
P)
|
||||
(|fetch| (QIX.POINT QY)
|
||||
P)
|
||||
(|fetch| (QIX.POINT QX)
|
||||
P2)
|
||||
(|fetch| (QIX.POINT QY)
|
||||
P2)))))
|
||||
(RPLACD (LAST L)
|
||||
L)
|
||||
LOOP
|
||||
(COND
|
||||
(*STOP.QIXS* (RPLACD L NIL)
|
||||
(RETURN NIL)))
|
||||
|
||||
(* * |Draw| |the| |QIX's| |head| |line.|)
|
||||
|
||||
(MOVETO (|fetch| X P)
|
||||
(|fetch| Y P)
|
||||
(* |;;;| "Draw the QIX's head line.")
|
||||
|
||||
(MOVETO (|fetch| (QIX.POINT QX)
|
||||
P)
|
||||
(|fetch| (QIX.POINT QY)
|
||||
P)
|
||||
W)
|
||||
(DRAWTO (|fetch| X P2)
|
||||
(|fetch| Y P2)
|
||||
(DRAWTO (|fetch| (QIX.POINT QX)
|
||||
P2)
|
||||
(|fetch| (QIX.POINT QY)
|
||||
P2)
|
||||
1
|
||||
'REPLACE W)
|
||||
|
||||
(* * |Move| |the| |points| |according| |to| |their| X |and| Y |velocities.|)
|
||||
|
||||
(* |;;;| "Move the points according to their QX and QY velocities.")
|
||||
|
||||
(QIX.MOVE.POINT P W)
|
||||
(QIX.MOVE.POINT P2 W)
|
||||
|
||||
(* * |Take| \a |deep| |breath| |if| |the| |user| |asks| |you| |to.|
|
||||
|This| |slows| |things| |down.|)
|
||||
|
||||
(* |;;;| "Take a deep breath if the user asks you to. This slows things down.")
|
||||
|
||||
(OR DONTDISMISS (DISMISS))
|
||||
|
||||
(* * |Delete| |the| |first| |object| |on| |the| |tail| |list.|)
|
||||
|
||||
(* |;;;| "Delete the first object on the tail list.")
|
||||
|
||||
(COND
|
||||
((EQ (CAAR L)
|
||||
@@ -93,60 +96,63 @@
|
||||
(CADDDR OLD)
|
||||
1
|
||||
'ERASE W))))
|
||||
|
||||
(* * |Replace| |the| |current| |point| |with| |the| |new| |head,| |which|
|
||||
|effectively| |adds| |it| |to| |the| |end| |of| |the| |list,| |since| |we|
|
||||
|them| |immediately| |move| |to| |the| |next| |elt| |in| |this| |circular|
|
||||
|list.|)
|
||||
|
||||
(* |;;;| "Replace the current point with the new head, which effectively adds it to the end of the list, since we them immediately move to the next elt in this circular list.")
|
||||
|
||||
(RPLACA (CAR L)
|
||||
(|fetch| X P))
|
||||
(|fetch| (QIX.POINT QX)
|
||||
P))
|
||||
(RPLACA (CDAR L)
|
||||
(|fetch| Y P))
|
||||
(|fetch| (QIX.POINT QY)
|
||||
P))
|
||||
(RPLACA (CDDAR L)
|
||||
(|fetch| X P2))
|
||||
(|fetch| (QIX.POINT QX)
|
||||
P2))
|
||||
(RPLACA (CDDDAR L)
|
||||
(|fetch| Y P2))
|
||||
(|fetch| (QIX.POINT QY)
|
||||
P2))
|
||||
(SETQ L (CDR L))
|
||||
(GO LOOP))))
|
||||
|
||||
(QIX.IDLE
|
||||
(LAMBDA (W) (* \; "Edited 24-Aug-2022 07:53 by larry")
|
||||
(LAMBDA (W) (* \; "Edited 14-Jun-2024 14:49 by rmk")
|
||||
(* \; "Edited 24-Aug-2022 07:53 by larry")
|
||||
(* \;
|
||||
"Edited 1-Aug-87 16:58 by JEFF.SHRAGER")
|
||||
|
||||
(* * CLOBBER ANY OLD QIXS THAT WERE LEFT AROUND
|
||||
(WASTING SPACE) FROM BEFORE.)
|
||||
(* |;;;| "CLOBBER ANY OLD QIXS THAT WERE LEFT AROUND (WASTING SPACE) FROM BEFORE.")
|
||||
|
||||
(AND (BOUNDP '*OLD-QIXS*)
|
||||
(FOR Q IN *OLD-QIXS* DO (RPLACD Q NIL)))
|
||||
(PROG (P P2 L QIXS)
|
||||
|
||||
(* * P |and| P2 |define| \a QIX.)
|
||||
(* |;;;| "P and P2 define a QIX.")
|
||||
|
||||
(SETQ QIXS (|for| I |from| 1 |to| 5
|
||||
|collect| (PROGN (SETQ P (|create| QIX.POINT
|
||||
X _ (RAND 1 200)
|
||||
Y _ (RAND 1 100)
|
||||
QX _ (RAND 1 200)
|
||||
QY _ (RAND 1 100)
|
||||
VH _ (RAND 1 20)
|
||||
VV _ (RAND 1 20)))
|
||||
(SETQ P2 (|create| QIX.POINT
|
||||
X _ (RAND 1 200)
|
||||
Y _ (RAND 1 100)
|
||||
QX _ (RAND 1 200)
|
||||
QY _ (RAND 1 100)
|
||||
VH _ (RAND 1 20)
|
||||
VV _ (RAND 1 20)))
|
||||
|
||||
(* * L |is| |the| |tail| |list.| I\t |starts| |out| |full| |of| NIL\s |and|
|
||||
|gets| |filled| |as| |the| QIX |moves.| I\t |is| |also| |inserted| |in| |it's|
|
||||
|own| |mouth| |so| |that| |the| |whole| |thing| |wraps| |around.|)
|
||||
(* |;;;| "L is the tail list. It starts out full of NILs and gets filled as the QIX moves. It is also inserted in it's own mouth so that the whole thing wraps around.")
|
||||
|
||||
(SETQ L
|
||||
(APPEND (|for| X |from| 1 |to| (RAND 5 25)
|
||||
|collect| (COPY '(A S D F)))
|
||||
(LIST (LIST (|fetch| X P)
|
||||
(|fetch| Y P)
|
||||
(|fetch| X P2)
|
||||
(|fetch| Y P2)))))
|
||||
(LIST (LIST (|fetch| (QIX.POINT QX)
|
||||
P)
|
||||
(|fetch| (QIX.POINT QY)
|
||||
P)
|
||||
(|fetch| (QIX.POINT QX)
|
||||
P2)
|
||||
(|fetch| (QIX.POINT QY)
|
||||
P2)))))
|
||||
(RPLACD (LAST L)
|
||||
L)
|
||||
(LIST P P2 L))))
|
||||
@@ -157,22 +163,26 @@
|
||||
(SETQ P2 (CADR Q))
|
||||
(SETQ L (CADDR Q))
|
||||
|
||||
(* * |Draw| |the| |QIX's| |head| |line.|)
|
||||
(* |;;;| "Draw the QIX's head line.")
|
||||
|
||||
(MOVETO (|fetch| X P)
|
||||
(|fetch| Y P)
|
||||
(MOVETO (|fetch| (QIX.POINT QX)
|
||||
P)
|
||||
(|fetch| (QIX.POINT QY)
|
||||
P)
|
||||
W)
|
||||
(DRAWTO (|fetch| X P2)
|
||||
(|fetch| Y P2)
|
||||
(DRAWTO (|fetch| (QIX.POINT QX)
|
||||
P2)
|
||||
(|fetch| (QIX.POINT QY)
|
||||
P2)
|
||||
1
|
||||
'REPLACE W)
|
||||
|
||||
(* * |Move| |the| |points| |according| |to| |their| X |and| Y |velocities.|)
|
||||
(* |;;;| "Move the points according to their QX and QY velocities.")
|
||||
|
||||
(QIX.MOVE.POINT P W)
|
||||
(QIX.MOVE.POINT P2 W)
|
||||
|
||||
(* * |Delete| |the| |first| |object| |on| |the| |tail| |list.|)
|
||||
(* |;;;| "Delete the first object on the tail list.")
|
||||
|
||||
(COND
|
||||
((EQ (CAAR L)
|
||||
@@ -186,34 +196,36 @@
|
||||
1
|
||||
'ERASE W))))
|
||||
|
||||
(* * |Replace| |the| |current| |point| |with| |the| |new| |head,| |which|
|
||||
|effectively| |adds| |it| |to| |the| |end| |of| |the| |list,| |since| |we| THEN
|
||||
|immediately| |move| |to| |the| |next| |elt| |in| |this| |circular| |list.|)
|
||||
(* |;;;| "Replace the current point with the new head, which effectively adds it to the end of the list, since we THEN immediately move to the next elt in this circular list.")
|
||||
|
||||
(RPLACA (CAR L)
|
||||
(|fetch| X P))
|
||||
(|fetch| (QIX.POINT QX)
|
||||
P))
|
||||
(RPLACA (CDAR L)
|
||||
(|fetch| Y P))
|
||||
(|fetch| (QIX.POINT QY)
|
||||
P))
|
||||
(RPLACA (CDDAR L)
|
||||
(|fetch| X P2))
|
||||
(|fetch| (QIX.POINT QX)
|
||||
P2))
|
||||
(RPLACA (CDDDAR L)
|
||||
(|fetch| Y P2))
|
||||
(|fetch| (QIX.POINT QY)
|
||||
P2))
|
||||
(RPLACA (CDDR Q)
|
||||
(CDR L)))
|
||||
(GO LOOP))))
|
||||
|
||||
(QIX.MOVE.POINT
|
||||
(LAMBDA (P W) (* |edited:| "16-May-85 00:39")
|
||||
|
||||
(* * |This| |guy| |updates| |the| QIX |line| |endpoints| |according| |to|
|
||||
|their| |velocities| |in| |the| X |and| Y |directions.|
|
||||
I\f |we| |hit| \a |wall,| |then| |simply| |negate| |the| |relevant| |velocity|
|
||||
|vector.|)
|
||||
(LAMBDA (P W) (* \; "Edited 14-Jun-2024 14:48 by rmk")
|
||||
(* |edited:| "16-May-85 00:39")
|
||||
|
||||
(* |;;;| "This guy updates the QIX line endpoints according to their velocities in the X and Y directions. If we hit a wall, then simply negate the relevant velocity vector.")
|
||||
|
||||
(PROG ((VV (|fetch| VV P))
|
||||
(VH (|fetch| VH P))
|
||||
(X (|fetch| X P))
|
||||
(Y (|fetch| Y P)))
|
||||
(X (|fetch| (QIX.POINT QX)
|
||||
P))
|
||||
(Y (|fetch| (QIX.POINT QY)
|
||||
P)))
|
||||
(PROG ((NEWX (IPLUS X VH))
|
||||
(NEWY (IPLUS Y VV)))
|
||||
(COND
|
||||
@@ -230,8 +242,10 @@
|
||||
((GREATERP NEWX (WINDOWPROP W 'WIDTH))
|
||||
(SETQ NEWX (WINDOWPROP W 'WIDTH))
|
||||
(SETQ VH (ITIMES -1 VH))))
|
||||
(|replace| Y P NEWY)
|
||||
(|replace| X P NEWX)
|
||||
(|replace| (QIX.POINT QY)
|
||||
P NEWY)
|
||||
(|replace| (QIX.POINT QX)
|
||||
P NEWX)
|
||||
(|replace| VV P VV)
|
||||
(|replace| VH P VH)))))
|
||||
|
||||
@@ -249,13 +263,12 @@
|
||||
)
|
||||
(DECLARE\: EVAL@COMPILE
|
||||
|
||||
(RECORD QIX.POINT (X Y VH VV))
|
||||
(RECORD QIX.POINT (QX QY VH VV))
|
||||
)
|
||||
|
||||
(SETQ IDLE.FUNCTIONS (CONS '("5 Qix's" 'QIX.IDLE)
|
||||
IDLE.FUNCTIONS))
|
||||
(PUTPROPS QIX COPYRIGHT ("Xerox Corporation" 1987))
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (592 11044 (QIX.GROW 602 . 4158) (QIX.IDLE 4160 . 8972) (QIX.MOVE.POINT 8974 . 10356) (
|
||||
QIX.PLAY 10358 . 11042)))))
|
||||
(FILEMAP (NIL (544 12010 (QIX.GROW 554 . 4311) (QIX.IDLE 4313 . 9800) (QIX.MOVE.POINT 9802 . 11322) (
|
||||
QIX.PLAY 11324 . 12008)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
219
lispusers/READ-BDF
Normal file
219
lispusers/READ-BDF
Normal file
@@ -0,0 +1,219 @@
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "BDF" ( USE "XCL" "LISP") ( EXPORT "READ-BDF")) READTABLE
|
||||
"XCL" BASE 10)
|
||||
|
||||
(IL:FILECREATED "23-Sep-2024 12:38:25" IL:{LU}READ-BDF.\;2 12260
|
||||
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (IL:FUNCTIONS READ-BDF READ-GLYPH)
|
||||
|
||||
:PREVIOUS-DATE "22-Aug-2024 20:54:00" IL:{LU}READ-BDF.\;1)
|
||||
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:READ-BDFCOMS)
|
||||
|
||||
(IL:RPAQQ IL:READ-BDFCOMS ((IL:STRUCTURES BDF-FONT GLYPH)
|
||||
(IL:FUNCTIONS READ-BDF READ-DELIMITED-LIST-FROM-STRING READ-GLYPH)
|
||||
(FILE-ENVIRONMENTS "READ-BDF")))
|
||||
|
||||
(DEFSTRUCT (BDF-FONT (:CONC-NAME "BF-"))
|
||||
(NAME NIL :TYPE STRING)
|
||||
(SIZE NIL :TYPE LIST)
|
||||
(BOUNDINGBOX NIL :TYPE LIST)
|
||||
(METRICSSET 0 :TYPE (INTEGER 0 2))
|
||||
(PROPERTIES NIL :TYPE LIST)
|
||||
SWIDTH DWIDTH SWIDTH1 DWIDTH1 VVECTOR (GLYPHS NIL :TYPE LIST))
|
||||
|
||||
(DEFSTRUCT GLYPH
|
||||
(NAME NIL :TYPE STRING)
|
||||
ENCODING SWIDTH DWIDTH SWIDTH1 DWIDTH1 VVECTOR BBW BBH BBXOFF0 BBYOFF0 BITMAP)
|
||||
|
||||
(DEFUN READ-BDF (PATH) (IL:* IL:\; "Edited 23-Sep-2024 12:37 by mth")
|
||||
(IL:* IL:\; "Edited 22-Aug-2024 16:43 by mth")
|
||||
(IL:* IL:\; "Edited 17-Jul-2024 14:45 by mth")
|
||||
(IL:* IL:\; "Edited 12-Jul-2024 23:02 by mth")
|
||||
(LET
|
||||
(PROPS PROPS-COMPLETE CHARS-COUNT FONT-COMPLETE FONT POS KEY V VV LINE ITEMS (NGLYPHS 0)
|
||||
(*PACKAGE* (FIND-PACKAGE "BDF")))
|
||||
(WITH-OPEN-FILE
|
||||
(FILE-STREAM PATH :ELEMENT-TYPE 'CHARACTER :DIRECTION :INPUT)
|
||||
(UNLESS (STRING-EQUAL "STARTFONT" (READ FILE-STREAM))
|
||||
(ERROR "Invalid BDF file - must begin with STARTFONT."))
|
||||
|
||||
(IL:* IL:|;;| "ignore the file format version number")
|
||||
|
||||
(READ-LINE FILE-STREAM)
|
||||
(SETQ FONT (MAKE-BDF-FONT))
|
||||
(LOOP
|
||||
:UNTIL FONT-COMPLETE :DO (SETQ LINE (READ-LINE FILE-STREAM))
|
||||
(WHEN LINE (IL:* IL:\; "Ignore blank lines")
|
||||
(MULTIPLE-VALUE-SETQ (KEY POS)
|
||||
(READ-FROM-STRING LINE))
|
||||
(UNLESS (MEMBER KEY '(COMMENT CONTENTVERSION))
|
||||
(WHEN (<= POS (LENGTH LINE))
|
||||
(SETQ LINE (SUBSEQ LINE POS)))
|
||||
(SETQ ITEMS (READ-DELIMITED-LIST-FROM-STRING LINE))
|
||||
(CASE KEY
|
||||
(FONT (SETF (BF-NAME FONT)
|
||||
LINE))
|
||||
(METRICSSET (IF (AND (INTEGERP (SETQ V (FIRST ITEMS)))
|
||||
(<= 0 V 2))
|
||||
(SETF (BF-METRICSSET FONT)
|
||||
V)
|
||||
(ERROR
|
||||
"Invalid BDF file - METRICSSET (~A) is invalid or out of range."
|
||||
V)))
|
||||
(SIZE (SETF (BF-SIZE FONT)
|
||||
ITEMS))
|
||||
(FONTBOUNDINGBOX (SETF (BF-BOUNDINGBOX FONT)
|
||||
ITEMS))
|
||||
(SWIDTH (SETF (BF-SWIDTH FONT)
|
||||
ITEMS))
|
||||
(DWIDTH (SETF (BF-DWIDTH FONT)
|
||||
ITEMS))
|
||||
(SWIDTH1 (SETF (BF-SWIDTH1 FONT)
|
||||
ITEMS))
|
||||
(DWIDTH1 (SETF (BF-DWIDTH1 FONT)
|
||||
ITEMS))
|
||||
(VVECTOR (SETF (BF-VVECTOR FONT)
|
||||
ITEMS))
|
||||
(STARTPROPERTIES
|
||||
(IF (AND (INTEGERP (SETQ V (FIRST ITEMS)))
|
||||
(PLUSP V))
|
||||
(SETQ PROPS (LOOP :UNTIL PROPS-COMPLETE :APPEND
|
||||
(WITH-INPUT-FROM-STRING
|
||||
(SI (SETQ LINE (READ-LINE FILE-STREAM)))
|
||||
(UNLESS (SETQ PROPS-COMPLETE
|
||||
(STRING-EQUAL "ENDPROPERTIES"
|
||||
(STRING-TRIM '(#\Space #\Tab)
|
||||
LINE)))
|
||||
(SETQ KEY (READ SI))
|
||||
(IF (AND KEY (SYMBOLP KEY)
|
||||
(SETQ VV (READ SI))
|
||||
(OR (STRINGP VV)
|
||||
(INTEGERP VV)))
|
||||
(LIST (INTERN (STRING KEY)
|
||||
"KEYWORD")
|
||||
VV)
|
||||
(ERROR
|
||||
"Invalid BDF file - malformed PROPERTY (~A)."
|
||||
LINE))))))
|
||||
(ERROR
|
||||
"Invalid BDF file - STARTPROPERTIES count (~A) is invalid or missing."
|
||||
V))
|
||||
(IF (EQL V (SETQ VV (/ (LENGTH PROPS)
|
||||
2)))
|
||||
(SETF (BF-PROPERTIES FONT)
|
||||
PROPS)
|
||||
(ERROR
|
||||
"Invalid BDF file - STARTPROPERTIES count (~D) does not match actual (~D)."
|
||||
V VV)))
|
||||
(CHARS
|
||||
(SETQ NGLYPHS (FIRST ITEMS))
|
||||
(UNLESS (AND NGLYPHS (INTEGERP NGLYPHS)
|
||||
(PLUSP NGLYPHS))
|
||||
(ERROR "Invalid BDF file - CHARS count (~A) is invalid or missing."
|
||||
NGLYPHS))
|
||||
(SETF (BF-GLYPHS FONT)
|
||||
(LOOP :REPEAT NGLYPHS :COLLECT (READ-GLYPH FILE-STREAM FONT))))
|
||||
(ENDFONT (SETQ FONT-COMPLETE T))))))
|
||||
FONT)))
|
||||
|
||||
(DEFUN READ-DELIMITED-LIST-FROM-STRING (INPUT-STRING &OPTIONAL (DELIMIT #\]))
|
||||
(IL:* IL:\; "Edited 20-Aug-2024 16:46 by mth")
|
||||
(WITH-INPUT-FROM-STRING (SI (CONCATENATE 'STRING INPUT-STRING " " (STRING DELIMIT)))
|
||||
(READ-DELIMITED-LIST DELIMIT SI)))
|
||||
|
||||
(DEFUN READ-GLYPH (FILE-STREAM FONT) (IL:* IL:\; "Edited 23-Sep-2024 12:38 by mth")
|
||||
(IL:* IL:\; "Edited 22-Aug-2024 20:53 by mth")
|
||||
(IL:* IL:\; "Edited 21-Aug-2024 01:10 by mth")
|
||||
(LET ((GLYPH (MAKE-GLYPH :SWIDTH (COPY-LIST (BF-SWIDTH FONT))
|
||||
:DWIDTH
|
||||
(COPY-LIST (BF-DWIDTH FONT))
|
||||
:SWIDTH1
|
||||
(COPY-LIST (BF-SWIDTH1 FONT))
|
||||
:DWIDTH1
|
||||
(COPY-LIST (BF-DWIDTH1 FONT))
|
||||
:VVECTOR
|
||||
(COPY-LIST (BF-VVECTOR FONT))))
|
||||
CHAR-COMPLETE LINE ITEMS V KEY POS STARTED BBW BBH)
|
||||
(LOOP :UNTIL CHAR-COMPLETE :DO (SETQ LINE (READ-LINE FILE-STREAM))
|
||||
(WHEN LINE (IL:* IL:\; "Ignore blank lines")
|
||||
(MULTIPLE-VALUE-SETQ (KEY POS)
|
||||
(READ-FROM-STRING LINE))
|
||||
(WHEN (<= POS (LENGTH LINE))
|
||||
(SETQ LINE (SUBSEQ LINE POS)))
|
||||
(SETQ ITEMS (READ-DELIMITED-LIST-FROM-STRING LINE))
|
||||
(COND
|
||||
((EQ KEY 'STARTCHAR)
|
||||
(WHEN STARTED (ERROR "Invalid BDF file - STARTCHAR inside glyph."))
|
||||
(SETF STARTED T)
|
||||
(SETF (GLYPH-NAME GLYPH)
|
||||
(STRING LINE)))
|
||||
(T (UNLESS STARTED (ERROR "Invalid BDF file - glyph has ben started."))
|
||||
(CASE KEY
|
||||
(ENCODING (SETF (GLYPH-ENCODING GLYPH)
|
||||
(IF (EQUAL -1 (FIRST ITEMS))
|
||||
ITEMS
|
||||
(FIRST ITEMS))))
|
||||
(SWIDTH (SETF (GLYPH-SWIDTH GLYPH)
|
||||
ITEMS))
|
||||
(DWIDTH (SETF (GLYPH-DWIDTH GLYPH)
|
||||
ITEMS))
|
||||
(SWIDTH1 (SETF (GLYPH-SWIDTH1 GLYPH)
|
||||
ITEMS))
|
||||
(DWIDTH1 (SETF (GLYPH-DWIDTH1 GLYPH)
|
||||
ITEMS))
|
||||
(VVECTOR (SETF (GLYPH-VVECTOR GLYPH)
|
||||
ITEMS))
|
||||
(BBX (SETF (GLYPH-BBW GLYPH)
|
||||
(SETQ BBW (FIRST ITEMS))
|
||||
(GLYPH-BBH GLYPH)
|
||||
(SETQ BBH (SECOND ITEMS))
|
||||
(GLYPH-BBXOFF0 GLYPH)
|
||||
(THIRD ITEMS)
|
||||
(GLYPH-BBYOFF0 GLYPH)
|
||||
(FOURTH ITEMS)))
|
||||
(BITMAP (LET* ((BM (IL:BITMAPCREATE BBW BBH 1))
|
||||
(BM.BASE (IL:|fetch| IL:BITMAPBASE IL:|of| BM))
|
||||
(BM.RASTERWIDTH (IL:|fetch| IL:BITMAPRASTERWIDTH
|
||||
IL:|of| BM))
|
||||
(NBYTES (CEILING BBW 8))
|
||||
(NCHARS (* 2 NBYTES))
|
||||
(NWORDS (CEILING BBW 16))
|
||||
BITS BYTEPOS WORDINDEX)
|
||||
(LOOP :WITH BITROW = 0 :REPEAT BBH :DO
|
||||
(SETQ LINE (STRING-TRIM '(#\Space #\Tab)
|
||||
(READ-LINE FILE-STREAM)))
|
||||
(UNLESS (AND (EQUAL NCHARS (LENGTH LINE))
|
||||
(SETQ BITS
|
||||
(PARSE-INTEGER LINE :RADIX 16
|
||||
:JUNK-ALLOWED T)))
|
||||
(ERROR
|
||||
"Invalid BDF file - bad line in BITMAP: ~A"
|
||||
LINE))
|
||||
(WHEN (ODDP NBYTES)
|
||||
(SETQ BITS (ASH BITS 8)))
|
||||
(SETQ WORDINDEX (* BITROW BM.RASTERWIDTH))
|
||||
(SETQ BYTEPOS (* 16 (1- NWORDS)))
|
||||
(LOOP :REPEAT NWORDS :DO
|
||||
(IL:\\PUTBASE BM.BASE WORDINDEX
|
||||
(LDB (BYTE 16 BYTEPOS)
|
||||
BITS))
|
||||
(INCF WORDINDEX)
|
||||
(DECF BYTEPOS 16))
|
||||
(INCF BITROW))
|
||||
(SETF (GLYPH-BITMAP GLYPH)
|
||||
BM)))
|
||||
(ENDCHAR (SETQ CHAR-COMPLETE T)))))))
|
||||
GLYPH))
|
||||
|
||||
(DEFINE-FILE-ENVIRONMENT "READ-BDF" :PACKAGE (DEFPACKAGE "BDF" (:USE "XCL" "LISP")
|
||||
(:EXPORT "READ-BDF"))
|
||||
:READTABLE "XCL"
|
||||
:COMPILER :COMPILE-FILE)
|
||||
(IL:PUTPROPS IL:READ-BDF IL:COPYRIGHT (IL:NONE))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (983 6167 (READ-BDF 983 . 6167)) (6169 6492 (READ-DELIMITED-LIST-FROM-STRING 6169 .
|
||||
6492)) (6494 11972 (READ-GLYPH 6494 . 11972)))))
|
||||
IL:STOP
|
||||
BIN
lispusers/READ-BDF.DFASL
Normal file
BIN
lispusers/READ-BDF.DFASL
Normal file
Binary file not shown.
@@ -1,16 +1,14 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "24-Aug-2022 08:54:17" {DSK}<home>larry>medley>lispusers>SOLITAIRE.;2 26883
|
||||
(FILECREATED "14-Jun-2024 15:48:55" {WMEDLEY}<lispusers>SOLITAIRE.;4 27251
|
||||
|
||||
:CHANGES-TO (FNS SOLO DEALDECK GETCARD)
|
||||
(VARS SOLITAIRECOMS)
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE "15-Jan-86 23:32:05" {DSK}<home>larry>medley>lispusers>SOLITAIRE.;1)
|
||||
:CHANGES-TO (RECORDS CARD)
|
||||
(FNS GETCARD MOVECARD UPCARD NXTCARD)
|
||||
|
||||
:PREVIOUS-DATE "24-Aug-2022 08:54:17" {WMEDLEY}<lispusers>SOLITAIRE.;2)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1982, 1985-1986 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT SOLITAIRECOMS)
|
||||
|
||||
@@ -169,11 +167,12 @@ Copyright (c) 1982, 1985-1986 by Xerox Corporation.
|
||||
else NIL])
|
||||
|
||||
(GETCARD
|
||||
[LAMBDA (I) (* bas%: "30-JUL-82 19:04")
|
||||
[LAMBDA (I) (* ; "Edited 14-Jun-2024 15:48 by rmk")
|
||||
(* bas%: "30-JUL-82 19:04")
|
||||
(PROG ((C (ELT DECK I)))
|
||||
(if (fetch FACE of C)
|
||||
else (replace FACE of C with (CARDIMAGE C))
|
||||
(replace SAV of C with (BITMAPCREATE CardWidth CardHeight)))
|
||||
(replace (CARD CDSAV) of C with (BITMAPCREATE CardWidth CardHeight)))
|
||||
(replace CX of C with (replace CY of C with NIL))
|
||||
(RETURN C])
|
||||
|
||||
@@ -192,13 +191,14 @@ Copyright (c) 1982, 1985-1986 by Xerox Corporation.
|
||||
then (SEARCHSTACKS (TOP H])
|
||||
|
||||
(MOVECARD
|
||||
[LAMBDA (C X Y) (* lmm " 6-Aug-85 00:04")
|
||||
[LAMBDA (C X Y) (* ; "Edited 14-Jun-2024 15:46 by rmk")
|
||||
(* lmm " 6-Aug-85 00:04")
|
||||
(if (fetch CX of C)
|
||||
then (DOMOVE (fetch FACE of C)
|
||||
(fetch CX of C)
|
||||
(fetch CY of C)
|
||||
X Y (fetch SAV of C))
|
||||
else (BITBLT SOLOW X Y (fetch SAV of C)
|
||||
X Y (fetch (CARD CDSAV) of C))
|
||||
else (BITBLT SOLOW X Y (fetch (CARD CDSAV) of C)
|
||||
NIL NIL NIL NIL 'INPUT 'REPLACE)
|
||||
(BITBLT (fetch FACE of C)
|
||||
NIL NIL SOLOW X Y NIL NIL 'INPUT 'REPLACE))
|
||||
@@ -264,7 +264,8 @@ Copyright (c) 1982, 1985-1986 by Xerox Corporation.
|
||||
(PUSHCARD S2 (CAR L])
|
||||
|
||||
(UPCARD
|
||||
[LAMBDA (X Y) (* lmm " 6-Aug-85 00:04")
|
||||
[LAMBDA (X Y) (* ; "Edited 14-Jun-2024 15:46 by rmk")
|
||||
(* lmm " 6-Aug-85 00:04")
|
||||
|
||||
(* Brings up X image which is assumed to be overlapped by Y image.
|
||||
Assumes YOFFSET only)
|
||||
@@ -272,14 +273,14 @@ Copyright (c) 1982, 1985-1986 by Xerox Corporation.
|
||||
(if Y
|
||||
then (PROG [(DY (IDIFFERENCE (fetch CY of X)
|
||||
(fetch CY of Y]
|
||||
(BITBLT (fetch SAV of X)
|
||||
0 0 (fetch SAV of Y)
|
||||
(BITBLT (fetch (CARD CDSAV) of X)
|
||||
0 0 (fetch (CARD CDSAV) of Y)
|
||||
0 DY CardWidth (IDIFFERENCE CardHeight DY)
|
||||
'INPUT
|
||||
'REPLACE)
|
||||
(BITBLT SOLOW (fetch CX of X)
|
||||
(fetch CY of X)
|
||||
(fetch SAV of X)
|
||||
(fetch (CARD CDSAV) of X)
|
||||
0 0 CardWidth (IDIFFERENCE CardHeight DY)
|
||||
'INPUT
|
||||
'REPLACE)
|
||||
@@ -308,7 +309,8 @@ Copyright (c) 1982, 1985-1986 by Xerox Corporation.
|
||||
(RETURN T])
|
||||
|
||||
(NXTCARD
|
||||
[LAMBDA (S) (* bas%: "15-Jan-86 21:44")
|
||||
[LAMBDA (S) (* ; "Edited 14-Jun-2024 15:46 by rmk")
|
||||
(* bas%: "15-Jan-86 21:44")
|
||||
(PROG1 (pop (fetch FACEDOWN of S))
|
||||
[if (fetch FACEDOWN of S)
|
||||
else
|
||||
@@ -335,7 +337,7 @@ Copyright (c) 1982, 1985-1986 by Xerox Corporation.
|
||||
'REPLACE)
|
||||
(if (fetch FACEUP of S)
|
||||
then (BLTSHADE (DSPTEXTURE NIL SOLOW)
|
||||
(fetch SAV of (BOTTOM S))
|
||||
(fetch (CARD CDSAV) of (BOTTOM S))
|
||||
0
|
||||
(IMINUS (fetch YO of S))
|
||||
(IDIFFERENCE CardWidth (fetch XO of S))
|
||||
@@ -531,7 +533,7 @@ Copyright (c) 1982, 1985-1986 by Xerox Corporation.
|
||||
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(DATATYPE CARD (SUIT RANK FACE SAV CX CY)
|
||||
(DATATYPE CARD (SUIT RANK FACE CDSAV CX CY)
|
||||
(ACCESSFNS CARD (COLOR (ILESSP (fetch SUIT of DATUM)
|
||||
Diamonds))))
|
||||
|
||||
@@ -642,15 +644,14 @@ Copyright (c) 1982, 1985-1986 by Xerox Corporation.
|
||||
(RPAQ? SOLORESULTS )
|
||||
|
||||
(ADDTOVAR IDLE.FUNCTIONS ("Solitaire" 'SOLO))
|
||||
(PUTPROPS SOLITAIRE COPYRIGHT ("Xerox Corporation" 1982 1985 1986))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1950 4087 (SOLO 1960 . 3297) (SOLITAIRE 3299 . 4085)) (4088 20454 (CARDIMAGE 4098 .
|
||||
5754) (COUNTCARDS 5756 . 5969) (CREATEHAND 5971 . 6576) (CREATESTACK 6578 . 7427) (DEALDECK 7429 .
|
||||
8012) (FLIPSTACK 8014 . 8249) (GETCARD 8251 . 8701) (GOODMOVE? 8703 . 9100) (HTOS? 9102 . 9269) (
|
||||
MOVECARD 9271 . 9910) (DOMOVE 9912 . 11543) (MOVEHS 11545 . 11816) (MOVES 11818 . 12129) (MOVES1 12131
|
||||
. 12433) (UPCARD 12435 . 13651) (MOVESSS 13653 . 14595) (NXTCARD 14597 . 16369) (PUSHCARD 16371 .
|
||||
17033) (POSTVALUE 17035 . 18036) (SEARCHSTACKS 18038 . 18281) (SHOWCARDSTACK 18283 . 18912) (
|
||||
SHUFFLEDECK 18914 . 19718) (STACKLOC 19720 . 20052) (STOS? 20054 . 20316) (TOPSUITSTACK 20318 . 20452)
|
||||
) (20455 22457 (HIST 20465 . 22054) (ARRAYMAX 22056 . 22455)) (22479 24001 (SHOWCONFIG 22489 . 22951)
|
||||
(PRINTCARDSTACK 22953 . 23305) (CARDNAME 23307 . 23999)))))
|
||||
(FILEMAP (NIL (1885 4022 (SOLO 1895 . 3232) (SOLITAIRE 3234 . 4020)) (4023 20888 (CARDIMAGE 4033 .
|
||||
5689) (COUNTCARDS 5691 . 5904) (CREATEHAND 5906 . 6511) (CREATESTACK 6513 . 7362) (DEALDECK 7364 .
|
||||
7947) (FLIPSTACK 7949 . 8184) (GETCARD 8186 . 8754) (GOODMOVE? 8756 . 9153) (HTOS? 9155 . 9322) (
|
||||
MOVECARD 9324 . 10090) (DOMOVE 10092 . 11723) (MOVEHS 11725 . 11996) (MOVES 11998 . 12309) (MOVES1
|
||||
12311 . 12613) (UPCARD 12615 . 13967) (MOVESSS 13969 . 14911) (NXTCARD 14913 . 16803) (PUSHCARD 16805
|
||||
. 17467) (POSTVALUE 17469 . 18470) (SEARCHSTACKS 18472 . 18715) (SHOWCARDSTACK 18717 . 19346) (
|
||||
SHUFFLEDECK 19348 . 20152) (STACKLOC 20154 . 20486) (STOS? 20488 . 20750) (TOPSUITSTACK 20752 . 20886)
|
||||
) (20889 22891 (HIST 20899 . 22488) (ARRAYMAX 22490 . 22889)) (22913 24435 (SHOWCONFIG 22923 . 23385)
|
||||
(PRINTCARDSTACK 23387 . 23739) (CARDNAME 23741 . 24433)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,19 +1,14 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "24-Sep-2023 14:26:57" {WMEDLEY}<lispusers>UNDIGESTIFY.;3 17040
|
||||
(FILECREATED " 3-Jun-2024 23:02:57" {WMEDLEY}<lispusers>UNDIGESTIFY.;5 16776
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS UNDIGESTIFYCOMS)
|
||||
(FNS OPEN-SPACE-IN-FILE)
|
||||
|
||||
:PREVIOUS-DATE "29-Jul-87 08:47:18" {WMEDLEY}<lispusers>UNDIGESTIFY.;1)
|
||||
:PREVIOUS-DATE " 3-Jun-2024 23:01:00" {WMEDLEY}<lispusers>UNDIGESTIFY.;4)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1986-1987 by Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT UNDIGESTIFYCOMS)
|
||||
|
||||
(RPAQQ UNDIGESTIFYCOMS
|
||||
@@ -22,8 +17,7 @@ Copyright (c) 1986-1987 by Xerox Corporation.
|
||||
(FNS INSTALL-UNDIGESTIFY LAFITE-DISPLAY LAFITE-TRUNCATE-FILE LAFITE-UNDIGESTIFY MOVE-TO-EOL
|
||||
OPEN-SPACE-IN-FILE PARSE-AND-MAYBE-MERGE-HEADER SKIP-EOLS BACKUP-PTR
|
||||
TEDIT.FIND.NOT.CASELESS)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (FROM library/LAFITE)
|
||||
LAFITEDECLS))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES LAFITE-DECLS))
|
||||
(P (INSTALL-UNDIGESTIFY))))
|
||||
|
||||
(RPAQ? *DELETE-DIGEST-FLAG* NIL)
|
||||
@@ -312,15 +306,13 @@ Copyright (c) 1986-1987 by Xerox Corporation.
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
(FILESLOAD (FROM library/LAFITE)
|
||||
LAFITEDECLS)
|
||||
(FILESLOAD LAFITE-DECLS)
|
||||
)
|
||||
|
||||
(INSTALL-UNDIGESTIFY)
|
||||
(PUTPROPS UNDIGESTIFY COPYRIGHT ("Xerox Corporation" 1986 1987))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1183 16831 (INSTALL-UNDIGESTIFY 1193 . 3206) (LAFITE-DISPLAY 3208 . 3507) (
|
||||
LAFITE-TRUNCATE-FILE 3509 . 3920) (LAFITE-UNDIGESTIFY 3922 . 13578) (MOVE-TO-EOL 13580 . 14040) (
|
||||
OPEN-SPACE-IN-FILE 14042 . 14762) (PARSE-AND-MAYBE-MERGE-HEADER 14764 . 15984) (SKIP-EOLS 15986 .
|
||||
16297) (BACKUP-PTR 16299 . 16461) (TEDIT.FIND.NOT.CASELESS 16463 . 16829)))))
|
||||
(FILEMAP (NIL (1016 16664 (INSTALL-UNDIGESTIFY 1026 . 3039) (LAFITE-DISPLAY 3041 . 3340) (
|
||||
LAFITE-TRUNCATE-FILE 3342 . 3753) (LAFITE-UNDIGESTIFY 3755 . 13411) (MOVE-TO-EOL 13413 . 13873) (
|
||||
OPEN-SPACE-IN-FILE 13875 . 14595) (PARSE-AND-MAYBE-MERGE-HEADER 14597 . 15817) (SKIP-EOLS 15819 .
|
||||
16130) (BACKUP-PTR 16132 . 16294) (TEDIT.FIND.NOT.CASELESS 16296 . 16662)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
143
scripts/clean_hcfiles.sh
Executable file
143
scripts/clean_hcfiles.sh
Executable file
@@ -0,0 +1,143 @@
|
||||
#!/bin/sh
|
||||
#
|
||||
# clean_hcfiles.sh
|
||||
#
|
||||
# Script to clean Medley directory after running do_hcfiles.sh.
|
||||
# Removes pdf files and index.html files created by do_hcfiles.sh.
|
||||
#
|
||||
# Caution: uses git clean - so it will delete any untracked files in
|
||||
# the Medley directory tree.
|
||||
#
|
||||
# FGH 2024-07-15
|
||||
#
|
||||
# Copyright 2024 Interlisp.org
|
||||
#
|
||||
|
||||
main() {
|
||||
|
||||
MEDLEYDIR=$(cd "${SCRIPTDIR}/.." && pwd)
|
||||
export MEDLEYDIR
|
||||
cd "${MEDLEYDIR}" || exit
|
||||
|
||||
shellfile=/tmp/checkgit-$$.sh
|
||||
|
||||
cat >"${shellfile}" <<-'EOF'
|
||||
#!/bin/sh
|
||||
git status --porcelain "$1" | grep --quiet --no-messages "??"
|
||||
if [ $? -eq 0 ]
|
||||
then
|
||||
rm -f "$1"
|
||||
rm -f "$1".~*~
|
||||
fi
|
||||
EOF
|
||||
|
||||
chmod +x "${shellfile}"
|
||||
|
||||
find . -iname index.html -exec "${shellfile}" {} \;
|
||||
find . -iname \*.pdf -exec "${shellfile}" {} \;
|
||||
|
||||
rm -f "${shellfile}"
|
||||
|
||||
}
|
||||
|
||||
|
||||
# shellcheck disable=SC2164,SC2034
|
||||
if [ -z "${SCRIPTDIR}" ]
|
||||
then
|
||||
#
|
||||
#
|
||||
# Some functions to determine what directory this script is being executed from
|
||||
#
|
||||
#
|
||||
get_abs_filename() {
|
||||
# $1 : relative filename
|
||||
echo "$(cd "$(dirname "$1")" && pwd)/$(basename "$1")"
|
||||
}
|
||||
|
||||
# This function taken from
|
||||
# https://stackoverflow.com/questions/29832037/how-to-get-script-directory-in-posix-sh
|
||||
rreadlink() (
|
||||
|
||||
# Execute this function in a *subshell* to localize variables and the effect of `cd`.
|
||||
|
||||
target=$1
|
||||
fname=
|
||||
targetDir=
|
||||
CDPATH=
|
||||
|
||||
# Try to make the execution environment as predictable as possible:
|
||||
# All commands below are invoked via `command`, so we must make sure that `command`
|
||||
# itself is not redefined as an alias or shell function.
|
||||
# (Note that command is too inconsistent across shells, so we don't use it.)
|
||||
# `command` is a *builtin* in bash, dash, ksh, zsh, and some platforms do not even have
|
||||
# an external utility version of it (e.g, Ubuntu).
|
||||
# `command` bypasses aliases and shell functions and also finds builtins
|
||||
# in bash, dash, and ksh. In zsh, option POSIX_BUILTINS must be turned on for that
|
||||
# to happen.
|
||||
{ \unalias command; \unset -f command; } >/dev/null 2>&1
|
||||
[ -n "$ZSH_VERSION" ] && options[POSIX_BUILTINS]=on # make zsh find *builtins* with `command` too.
|
||||
|
||||
while :; do # Resolve potential symlinks until the ultimate target is found.
|
||||
[ -L "$target" ] || [ -e "$target" ] || { command printf '%s\n' "ERROR: '$target' does not exist." >&2; return 1; }
|
||||
command cd "$(command dirname -- "$target")" # Change to target dir; necessary for correct resolution of target path.
|
||||
fname=$(command basename -- "$target") # Extract filename.
|
||||
[ "$fname" = '/' ] && fname='' # !! curiously, `basename /` returns '/'
|
||||
if [ -L "$fname" ]; then
|
||||
# Extract [next] target path, which may be defined
|
||||
# *relative* to the symlink's own directory.
|
||||
# Note: We parse `ls -l` output to find the symlink target
|
||||
# which is the only POSIX-compliant, albeit somewhat fragile, way.
|
||||
target=$(command ls -l "$fname")
|
||||
target=${target#* -> }
|
||||
continue # Resolve [next] symlink target.
|
||||
fi
|
||||
break # Ultimate target reached.
|
||||
done
|
||||
targetDir=$(command pwd -P) # Get canonical dir. path
|
||||
# Output the ultimate target's canonical path.
|
||||
# Note that we manually resolve paths ending in /. and /.. to make sure we have a normalized path.
|
||||
if [ "$fname" = '.' ]; then
|
||||
command printf '%s\n' "${targetDir%/}"
|
||||
elif [ "$fname" = '..' ]; then
|
||||
# Caveat: something like /var/.. will resolve to /private (assuming /var@ -> /private/var), i.e. the '..' is applied
|
||||
# AFTER canonicalization.
|
||||
command printf '%s\n' "$(command dirname -- "${targetDir}")"
|
||||
else
|
||||
command printf '%s\n' "${targetDir%/}/$fname"
|
||||
fi
|
||||
)
|
||||
|
||||
get_script_dir() {
|
||||
|
||||
# call this with $0 (from main script) as its (only) parameter
|
||||
# if you need to preserve cwd, run this is a subshell since
|
||||
# it can change cwd
|
||||
|
||||
# set -x
|
||||
|
||||
local_SCRIPT_PATH="$( get_abs_filename "$1" )";
|
||||
|
||||
while [ -h "$local_SCRIPT_PATH" ];
|
||||
do
|
||||
cd "$( dirname -- "$local_SCRIPT_PATH"; )";
|
||||
local_SCRIPT_PATH="$( rreadlink "$local_SCRIPT_PATH" )";
|
||||
done
|
||||
|
||||
cd "$( dirname -- "$local_SCRIPT_PATH"; )" > '/dev/null';
|
||||
local_SCRIPT_PATH="$( pwd; )";
|
||||
|
||||
# set +x
|
||||
|
||||
echo "${local_SCRIPT_PATH}"
|
||||
}
|
||||
|
||||
# end of script directory functions
|
||||
###############################################################################
|
||||
|
||||
# figure out the script dir
|
||||
SCRIPTDIR="$(get_script_dir "$0")"
|
||||
export SCRIPTDIR
|
||||
|
||||
fi
|
||||
|
||||
main "$@"
|
||||
159
scripts/do_hcfiles.sh
Executable file
159
scripts/do_hcfiles.sh
Executable file
@@ -0,0 +1,159 @@
|
||||
#!/bin/sh
|
||||
#
|
||||
# do_hcfiles.sh
|
||||
#
|
||||
# Script to run HCFILES in Medley to create PDFs of Medley files as well as
|
||||
# index.html files so that the Medley directory tree plus the generated PDFs can be
|
||||
# stored on and accessed from a web server
|
||||
#
|
||||
# FGH 2024-07-15
|
||||
#
|
||||
# Copyright 2024 Interlisp.org
|
||||
#
|
||||
|
||||
main() {
|
||||
MEDLEYDIR=$(cd "${SCRIPTDIR}/.." && pwd)
|
||||
export MEDLEYDIR
|
||||
logindir=/tmp/hcfiles-$$
|
||||
mkdir -p "${logindir}"
|
||||
cmfile=${logindir}/hcfiles.cm
|
||||
|
||||
cat >"${cmfile}" <<-EOF
|
||||
"
|
||||
|
||||
(PROGN
|
||||
(IL:MEDLEY-INIT-VARS 'IL:GREET)
|
||||
(IL:FILESLOAD MEDLEY-UTILS PDFSTREAM GITFNS))
|
||||
(IL:DRIBBLE '{DSK}${logindir}/hcfiles.dribble)
|
||||
(IL:SETQ IL:*UPPER-CASE-FILE-NAMES* NIL)
|
||||
(IL:SETQ IL:NO-HELP NIL)
|
||||
(IL:ADVISE 'IL:UNSAFE.TO.MODIFY :BEFORE '(RETURN NIL))
|
||||
(IL:ADVISE 'IL:HELP :BEFORE '(IL:COND (IL:NO-HELP (IL:ERROR IL:MESS1 IL:MESS2 T))))
|
||||
(IL:LET ((IL:NO-HELP T)) (DECLARE (SPECIAL IL:NO-HELP)) (IL:HCFILES))
|
||||
(IL:MAKE-INDEX-HTMLS)
|
||||
(IL:DRIBBLE)
|
||||
(IL:LOGOUT T)
|
||||
)
|
||||
|
||||
"
|
||||
EOF
|
||||
|
||||
/bin/sh "${MEDLEYDIR}/scripts/medley/medley.command" \
|
||||
--config - \
|
||||
--id hcfiles_+ \
|
||||
--geometry 1024x768 \
|
||||
--noscroll \
|
||||
--logindir "${logindir}" \
|
||||
--greet "${cmfile}" \
|
||||
--apps
|
||||
|
||||
# save dribble file to loadups; extract and save fails
|
||||
"${MEDLEYDIR}"/scripts/cpv ${logindir}/HCFILES.DRIBBLE "${MEDLEYDIR}"/loadups/hcfiles.dribble
|
||||
grep "IL:FAIL" < "${MEDLEYDIR}"/loadups/hcfiles.dribble > ${logindir}/fails
|
||||
"${MEDLEYDIR}"/scripts/cpv ${logindir}/fails "${MEDLEYDIR}"/loadups/hcfiles-fails.txt
|
||||
|
||||
# cleanup
|
||||
rm -rf "${logindir}"
|
||||
|
||||
}
|
||||
|
||||
# shellcheck disable=SC2164,SC2034
|
||||
if [ -z "${SCRIPTDIR}" ]
|
||||
then
|
||||
#
|
||||
#
|
||||
# Some functions to determine what directory this script is being executed from
|
||||
#
|
||||
#
|
||||
get_abs_filename() {
|
||||
# $1 : relative filename
|
||||
echo "$(cd "$(dirname "$1")" && pwd)/$(basename "$1")"
|
||||
}
|
||||
|
||||
# This function taken from
|
||||
# https://stackoverflow.com/questions/29832037/how-to-get-script-directory-in-posix-sh
|
||||
rreadlink() (
|
||||
|
||||
# Execute this function in a *subshell* to localize variables and the effect of `cd`.
|
||||
|
||||
target=$1
|
||||
fname=
|
||||
targetDir=
|
||||
CDPATH=
|
||||
|
||||
# Try to make the execution environment as predictable as possible:
|
||||
# All commands below are invoked via `command`, so we must make sure that `command`
|
||||
# itself is not redefined as an alias or shell function.
|
||||
# (Note that command is too inconsistent across shells, so we don't use it.)
|
||||
# `command` is a *builtin* in bash, dash, ksh, zsh, and some platforms do not even have
|
||||
# an external utility version of it (e.g, Ubuntu).
|
||||
# `command` bypasses aliases and shell functions and also finds builtins
|
||||
# in bash, dash, and ksh. In zsh, option POSIX_BUILTINS must be turned on for that
|
||||
# to happen.
|
||||
{ \unalias command; \unset -f command; } >/dev/null 2>&1
|
||||
[ -n "$ZSH_VERSION" ] && options[POSIX_BUILTINS]=on # make zsh find *builtins* with `command` too.
|
||||
|
||||
while :; do # Resolve potential symlinks until the ultimate target is found.
|
||||
[ -L "$target" ] || [ -e "$target" ] || { command printf '%s\n' "ERROR: '$target' does not exist." >&2; return 1; }
|
||||
command cd "$(command dirname -- "$target")" # Change to target dir; necessary for correct resolution of target path.
|
||||
fname=$(command basename -- "$target") # Extract filename.
|
||||
[ "$fname" = '/' ] && fname='' # !! curiously, `basename /` returns '/'
|
||||
if [ -L "$fname" ]; then
|
||||
# Extract [next] target path, which may be defined
|
||||
# *relative* to the symlink's own directory.
|
||||
# Note: We parse `ls -l` output to find the symlink target
|
||||
# which is the only POSIX-compliant, albeit somewhat fragile, way.
|
||||
target=$(command ls -l "$fname")
|
||||
target=${target#* -> }
|
||||
continue # Resolve [next] symlink target.
|
||||
fi
|
||||
break # Ultimate target reached.
|
||||
done
|
||||
targetDir=$(command pwd -P) # Get canonical dir. path
|
||||
# Output the ultimate target's canonical path.
|
||||
# Note that we manually resolve paths ending in /. and /.. to make sure we have a normalized path.
|
||||
if [ "$fname" = '.' ]; then
|
||||
command printf '%s\n' "${targetDir%/}"
|
||||
elif [ "$fname" = '..' ]; then
|
||||
# Caveat: something like /var/.. will resolve to /private (assuming /var@ -> /private/var), i.e. the '..' is applied
|
||||
# AFTER canonicalization.
|
||||
command printf '%s\n' "$(command dirname -- "${targetDir}")"
|
||||
else
|
||||
command printf '%s\n' "${targetDir%/}/$fname"
|
||||
fi
|
||||
)
|
||||
|
||||
get_script_dir() {
|
||||
|
||||
# call this with $0 (from main script) as its (only) parameter
|
||||
# if you need to preserve cwd, run this is a subshell since
|
||||
# it can change cwd
|
||||
|
||||
# set -x
|
||||
|
||||
local_SCRIPT_PATH="$( get_abs_filename "$1" )";
|
||||
|
||||
while [ -h "$local_SCRIPT_PATH" ];
|
||||
do
|
||||
cd "$( dirname -- "$local_SCRIPT_PATH"; )";
|
||||
local_SCRIPT_PATH="$( rreadlink "$local_SCRIPT_PATH" )";
|
||||
done
|
||||
|
||||
cd "$( dirname -- "$local_SCRIPT_PATH"; )" > '/dev/null';
|
||||
local_SCRIPT_PATH="$( pwd; )";
|
||||
|
||||
# set +x
|
||||
|
||||
echo "${local_SCRIPT_PATH}"
|
||||
}
|
||||
|
||||
# end of script directory functions
|
||||
###############################################################################
|
||||
|
||||
# figure out the script dir
|
||||
SCRIPTDIR="$(get_script_dir "$0")"
|
||||
export SCRIPTDIR
|
||||
|
||||
fi
|
||||
|
||||
main "$@"
|
||||
@@ -3,71 +3,65 @@ HCFILES writes in {MEDLEYDIR} but it should write in something like (SRCDIR)
|
||||
|
||||
# setup
|
||||
|
||||
github pages are maintained in the 'src' repository as a forked repo
|
||||
If you don't have a clone of src:
|
||||
```
|
||||
gh repo clone interlisp/src # make one
|
||||
cd src # all other commands
|
||||
```
|
||||
the first time once you've cloned, point the 'src' clone
|
||||
```
|
||||
gh remote add upstream https://github.com/interlisp/medley
|
||||
## Remove extraneous files
|
||||
|
||||
There are lots of ways to get there but basically set up the execution environment with everything clean but notecards loops, test are copied in. If you don't make fresh, at least 'git clean'.
|
||||
|
||||
```
|
||||
now update src repository to match 'medley'
|
||||
Run these in the 'src' repository!
|
||||
gh repo clone interlisp/medley
|
||||
gh repo clone interlisp/notecards
|
||||
gh repo clone interlisp/loops
|
||||
gh repo clone interlisp/test
|
||||
|
||||
```
|
||||
git fetch upstream # pull down remote branches
|
||||
git checkout master # make sure you're in master
|
||||
git rebase upstream/master # update src's master
|
||||
# to latest medley's master
|
||||
git push -f origin master # push back go sfc
|
||||
cp -r notecards loops test medley
|
||||
rm -rf notecards/.git loops/.git test/.git
|
||||
```
|
||||
|
||||
# Run Medly to create PDFs.
|
||||
# making the .pdfs and index.html files
|
||||
|
||||
Start with the apps sysout to spare yourself package problems
|
||||
In an Interlisp exec:
|
||||
## best start with a fresh loadup
|
||||
```
|
||||
(FILESLOAD PDFSTREAM GITFNS MEDLEY-UTILS)
|
||||
(HCFILES)
|
||||
(MAKE-INDEX-HTMLS)
|
||||
```
|
||||
check out that it looks right if you point your browser the index/index.hrml at the top level
|
||||
|
||||
# deploying
|
||||
|
||||
* find the current release tags
|
||||
Not sure how to do that.
|
||||
|
||||
```
|
||||
wget -l 1 https://github.com/interlisp/medley/releases/latest
|
||||
```
|
||||
will retrieve a 3xx redirect from the web server;
|
||||
But all you need is the name, not the web page.
|
||||
anyway, assuming the release is medley-YYMMDD-xxxxxxx.
|
||||
|
||||
put release name in variable
|
||||
```
|
||||
export release=medley-240420-1234567
|
||||
```
|
||||
## make a new branch
|
||||
```
|
||||
git checkout -b pages-$release
|
||||
```
|
||||
*temporarily* change .gitignore to allow checkin of pdfs and index.html
|
||||
```
|
||||
cp .gitignore /tmp/save$release
|
||||
cp .gitignore.for.pages .gitignore
|
||||
```
|
||||
Now you can push this to the github-pages
|
||||
```
|
||||
git add .
|
||||
git commit -m "rerun making ghpages and index"
|
||||
git push
|
||||
./scripts/loadup-all.sh
|
||||
```
|
||||
|
||||
# Now run in Medley "apps" loadup
|
||||
```
|
||||
./medley -a &
|
||||
```
|
||||
and enter the following to make the PDFs and the index.html files that links them.
|
||||
|
||||
```
|
||||
(DRIBBLE "medley/loadups/hcfiles.dribble")
|
||||
|
||||
(FILESLOAD MEDLEY-UTILS PDFSTREAM GITFNS)
|
||||
|
||||
(SETQ NO-HELP NIL)
|
||||
ADVISE(HELP :BEFORE (IF NO-HELP THEN ( (ERROR MESS1 MESS2)))
|
||||
(LET ((NO-HELP T)) (DECLARE (SPECIAL NO-HELP)) (HCFILES)))
|
||||
|
||||
(MAKE-INDEX-HTML)
|
||||
```
|
||||
# Deploying
|
||||
|
||||
The trick is to take a repository based on the master branch of medley and produce a gh-pages branch in the Interlisp/src reposiory.
|
||||
|
||||
```
|
||||
git remote set-url --push https://github.com/Interlisp/src
|
||||
git branch -D gh-pages ## if necessary
|
||||
git checkout -b gh-pages ## make the current directory content the same
|
||||
|
||||
## make sure the .gitignore DOESN'T ignore .pdf and index.html files
|
||||
|
||||
git add .
|
||||
git commit -m "add created pdf's and index.html's"
|
||||
git push --force
|
||||
|
||||
# Put it all back
|
||||
|
||||
after you've done this, you can clean up (from the medley folder):
|
||||
```
|
||||
find . -iname "*.pdf" -exec rm {} \;
|
||||
git remote set-url --push https://github.com/Interlisp/medley
|
||||
rm -rf loops notecards test
|
||||
```
|
||||
|
||||
|
||||
@@ -318,15 +318,20 @@ IL_DIR="$(cd "${MEDLEYDIR}/.."; pwd)"
|
||||
wsl=false
|
||||
darwin=false
|
||||
cygwin=false
|
||||
linux=false
|
||||
platform=unknown
|
||||
|
||||
if [ "$(uname)" = "Darwin" ]
|
||||
then
|
||||
darwin=true
|
||||
platform=darwin
|
||||
elif [ "$(uname -s | head --bytes 6)" = "CYGWIN" ]
|
||||
then
|
||||
cygwin=true
|
||||
platform=cgwin
|
||||
elif [ -e "/proc/version" ] && grep --ignore-case --quiet Microsoft /proc/version
|
||||
then
|
||||
platform=wsl
|
||||
wsl=true
|
||||
wsl_ver=0
|
||||
# WSL2
|
||||
@@ -351,7 +356,19 @@ Exiting"
|
||||
fi
|
||||
fi
|
||||
fi
|
||||
else
|
||||
linux=true
|
||||
platform=linux
|
||||
fi
|
||||
#################### TEST CODE ####################
|
||||
|
||||
#wsl=false
|
||||
#darwin=false
|
||||
#cygwin=false
|
||||
#linux=true
|
||||
#platform=linux
|
||||
|
||||
#################### TEST CODE ####################
|
||||
|
||||
# process config file and args
|
||||
# shellcheck source=./medley_configfile.sh
|
||||
@@ -552,8 +569,8 @@ flags:
|
||||
-t STRING | --title STRING : use STRING as title of window
|
||||
|
||||
-d :N | --display :N : use X display :N
|
||||
+w
|
||||
+w -v | --vnc : (WSL only) Use a VNC window instead of an X window
|
||||
|
||||
-v | --vnc : Use a VNC window instead of an X window (Not available: MacOS & Windows/Cygwin)
|
||||
|
||||
-i STRING | --id STRING : use STRING as the id for this run of Medley (default: default)
|
||||
|
||||
@@ -805,13 +822,32 @@ do
|
||||
use_vnc=true
|
||||
;;
|
||||
esac
|
||||
if [ "${use_vnc}" = true ] && { [ ! "${wsl}" = true ] || [ ! "$(uname -m)" = x86_64 ] ; }
|
||||
if [ "${use_vnc}" = true ]
|
||||
then
|
||||
echo "Warning: The -v or --vnc flag was set."
|
||||
echo "But the vnc option is only available when running on "
|
||||
echo "Windows System for Linux (wsl) on x86_64 machines."
|
||||
echo "Ignoring the -v or --vnc flag."
|
||||
use_vnc=false
|
||||
case ${platform} in
|
||||
darwin)
|
||||
echo "Warning The -v (--vnc) flag was set, but the vnc option is"
|
||||
echo "not available on MacOS. Ignoring the -v (--vnc) flag."
|
||||
use_vnc=false
|
||||
;;
|
||||
cygwin)
|
||||
echo "Warning The -v (--vnc) flag was set, but the vnc option is"
|
||||
echo "not available on Windows (Cygwin). Ignoring the -v (--vnc) flag."
|
||||
use_vnc=false
|
||||
;;
|
||||
wsl)
|
||||
if [ ! "$(uname -m)" = x86_64 ]
|
||||
then
|
||||
echo "Warning: The -v or --vnc flag was set."
|
||||
echo "But the vnc option is only available when running on "
|
||||
echo "Windows System for Linux (wsl) on x86_64 machines."
|
||||
echo "Ignoring the -v or --vnc flag."
|
||||
use_vnc=false
|
||||
fi
|
||||
;;
|
||||
linux)
|
||||
;;
|
||||
esac
|
||||
fi
|
||||
;;
|
||||
-x | --logindir)
|
||||
@@ -1380,9 +1416,9 @@ fi
|
||||
|
||||
|
||||
# Run maiko either directly or with vnc
|
||||
if [ "${wsl}" = true ] && [ "${use_vnc}" = true ]
|
||||
if [ "${use_vnc}" = true ]
|
||||
then
|
||||
# do the vnc thing on wsl (if called for)
|
||||
# do the vnc thing - if called for
|
||||
# shellcheck source=./medley_vnc.sh
|
||||
# . "${SCRIPTDIR}/medley_vnc.sh"
|
||||
# shellcheck shell=sh
|
||||
@@ -1402,9 +1438,14 @@ then
|
||||
# Copyright 2023 Interlisp.org
|
||||
#
|
||||
###############################################################################
|
||||
|
||||
#set -x
|
||||
ip_addr() {
|
||||
ip -4 -br address show dev eth0 | awk '{print $3}' | sed 's-/.*$--'
|
||||
if [ "${wsl}" = true ]
|
||||
then
|
||||
ip -4 -br address show dev eth0 | awk '{print $3}' | sed 's-/.*$--'
|
||||
else
|
||||
echo "127.0.0.1"
|
||||
fi
|
||||
}
|
||||
|
||||
find_open_display() {
|
||||
@@ -1446,21 +1487,39 @@ then
|
||||
}
|
||||
|
||||
#
|
||||
# Make sure prequisites for vnc support in wsl are in place
|
||||
# Make sure prequisites for vnc support are in place
|
||||
#
|
||||
if [ "${use_vnc}" = "true" ];
|
||||
if [ -z "$(which Xvnc)" ] || [ "$(Xvnc -version 2>&1 | grep -iq tigervnc; echo $?)" -eq 1 ]
|
||||
then
|
||||
echo "Error: The -v or --vnc flag was set."
|
||||
echo "But it appears that that TigerVNC server \(Xvnc\) has not been installed."
|
||||
echo "Please install the TigerVNC server and try again. On Debian and Ubuntu, use:"
|
||||
echo "\"sudo apt install tigervnc-standalone-server\". On most other Linux distros, use the"
|
||||
echo "distro's package manager to install the \"tigervnc-server\" package."
|
||||
echo "Exiting."
|
||||
exit 4
|
||||
fi
|
||||
if [ "${linux}" = "true" ]
|
||||
then
|
||||
if [ -z "$(which vncviewer)" ] || [ "$(vncviewer -v 2>&1 | head -2 | grep -iq tigervnc; echo $?)" -eq 1 ]
|
||||
then
|
||||
echo "Error: The -v or --vnc flag was set."
|
||||
echo "But it appears that that the TigerVNC viewer \(vncviewer\) is not installed on your system."
|
||||
echo "Please install the TigerVNC viewer and try again. On Debian and Ubuntu, use:"
|
||||
echo "\"sudo apt install tigervnc-viewer\". On most other Linux distros, use the"
|
||||
echo "the distro's package manager to install the \"tigervnc-viewer\" (or sometimes just \"tigervnc\")"
|
||||
echo "package."
|
||||
echo "Exiting."
|
||||
exit 5
|
||||
else
|
||||
vncviewer="$(which vncviewer)"
|
||||
fi
|
||||
elif [ "${wsl}" = "true" ]
|
||||
then
|
||||
win_userprofile="$(cmd.exe /c "<nul set /p=%UserProfile%" 2>/dev/null)"
|
||||
vnc_dir="$(wslpath "${win_userprofile}")/AppData/Local/Interlisp"
|
||||
vnc_exe="vncviewer64-1.12.0.exe"
|
||||
if [ "$(which Xvnc)" = "" ] || [ "$(Xvnc -version 2>&1 | grep -iq tigervnc; echo $?)" -eq 1 ]
|
||||
then
|
||||
echo "Error: The -v or --vnc flag was set."
|
||||
echo "But it appears that that TigerVNC \(Xvnc\) has not been installed."
|
||||
echo "Please install TigerVNC using \"sudo apt install tigervnc-standalone-server tigervnc-xorg-extension\""
|
||||
echo "Exiting."
|
||||
exit 4
|
||||
elif [ ! -e "${vnc_dir}/${vnc_exe}" ];
|
||||
if [ ! -e "${vnc_dir}/${vnc_exe}" ];
|
||||
then
|
||||
if [ -e "${IL_DIR}/wsl/${vnc_exe}" ];
|
||||
then
|
||||
@@ -1494,6 +1553,7 @@ then
|
||||
done
|
||||
fi
|
||||
fi
|
||||
vncviewer="${vnc_dir}/${vnc_exe}"
|
||||
fi
|
||||
#
|
||||
# Start the log file so we can trace any issues with vnc, etc
|
||||
@@ -1513,6 +1573,7 @@ then
|
||||
# find an unused display and an available port
|
||||
#
|
||||
#set -x
|
||||
ORIGINAL_DISPLAY="${DISPLAY}"
|
||||
OPEN_DISPLAY="$(find_open_display)"
|
||||
if [ "${OPEN_DISPLAY}" -eq -1 ];
|
||||
then
|
||||
@@ -1539,15 +1600,15 @@ then
|
||||
# Start the Xvnc server
|
||||
#
|
||||
mkdir -p "${LOGINDIR}"/logs
|
||||
/usr/bin/Xvnc "${DISPLAY}" \
|
||||
-rfbport "${VNC_PORT}" \
|
||||
-geometry "${geometry}" \
|
||||
-SecurityTypes None \
|
||||
-NeverShared \
|
||||
-DisconnectClients=0 \
|
||||
-desktop "${title}" \
|
||||
--MaxDisconnectionTime=10 \
|
||||
>> "${LOG}" 2>&1 &
|
||||
Xvnc "${DISPLAY}" \
|
||||
-rfbport "${VNC_PORT}" \
|
||||
-geometry "${geometry}" \
|
||||
-SecurityTypes None \
|
||||
-NeverShared \
|
||||
-DisconnectClients=0 \
|
||||
-desktop "${title}" \
|
||||
--MaxDisconnectionTime=10 \
|
||||
>> "${LOG}" 2>&1 &
|
||||
|
||||
sleep .5
|
||||
#
|
||||
@@ -1557,25 +1618,24 @@ then
|
||||
start_maiko "$@"
|
||||
if [ -n "$(pgrep -f "${vnc_exe}.*:${VNC_PORT}")" ]; then vncconfig -disconnect; fi
|
||||
} &
|
||||
|
||||
#
|
||||
# Start the vncviewer on the windows side
|
||||
# Start the vncviewer
|
||||
#
|
||||
|
||||
# First give medley time to startup
|
||||
# sleep .25
|
||||
# SLeep appears not to be needed, but faster/slower machines ????
|
||||
# Sleep appears not to be needed, but faster/slower machines ????
|
||||
# FGH 2023-02-08
|
||||
|
||||
# Then start vnc viewer on Windows side
|
||||
# Then start vnc viewer
|
||||
vncv_loc=$(( OPEN_DISPLAY * 50 ))
|
||||
start_time=$(date +%s)
|
||||
"${vnc_dir}"/${vnc_exe} \
|
||||
-geometry "+${vncv_loc}+${vncv_loc}" \
|
||||
-ReconnectOnError=off \
|
||||
−AlertOnFatalError=off \
|
||||
"$(ip_addr)":"${VNC_PORT}" \
|
||||
>>"${LOG}" 2>&1 &
|
||||
export DISPLAY="${ORIGINAL_DISPLAY}"
|
||||
"${vncviewer}" -geometry "+${vncv_loc}+${vncv_loc}" \
|
||||
−AlertOnFatalError=0 \
|
||||
-ReconnectOnError=0 \
|
||||
"$(ip_addr)":"${VNC_PORT}" \
|
||||
>>"${LOG}" 2>&1 &
|
||||
wait $!
|
||||
if [ $(( $(date +%s) - start_time )) -lt 5 ]
|
||||
then
|
||||
|
||||
@@ -239,13 +239,32 @@ do
|
||||
use_vnc=true
|
||||
;;
|
||||
esac
|
||||
if [ "${use_vnc}" = true ] && { [ ! "${wsl}" = true ] || [ ! "$(uname -m)" = x86_64 ] ; }
|
||||
if [ "${use_vnc}" = true ]
|
||||
then
|
||||
echo "Warning: The -v or --vnc flag was set."
|
||||
echo "But the vnc option is only available when running on "
|
||||
echo "Windows System for Linux (wsl) on x86_64 machines."
|
||||
echo "Ignoring the -v or --vnc flag."
|
||||
use_vnc=false
|
||||
case ${platform} in
|
||||
darwin)
|
||||
echo "Warning The -v (--vnc) flag was set, but the vnc option is"
|
||||
echo "not available on MacOS. Ignoring the -v (--vnc) flag."
|
||||
use_vnc=false
|
||||
;;
|
||||
cygwin)
|
||||
echo "Warning The -v (--vnc) flag was set, but the vnc option is"
|
||||
echo "not available on Windows (Cygwin). Ignoring the -v (--vnc) flag."
|
||||
use_vnc=false
|
||||
;;
|
||||
wsl)
|
||||
if [ ! "$(uname -m)" = x86_64 ]
|
||||
then
|
||||
echo "Warning: The -v or --vnc flag was set."
|
||||
echo "But the vnc option is only available when running on "
|
||||
echo "Windows System for Linux (wsl) on x86_64 machines."
|
||||
echo "Ignoring the -v or --vnc flag."
|
||||
use_vnc=false
|
||||
fi
|
||||
;;
|
||||
linux)
|
||||
;;
|
||||
esac
|
||||
fi
|
||||
;;
|
||||
-x | --logindir)
|
||||
|
||||
@@ -128,15 +128,20 @@ IL_DIR="$(cd "${MEDLEYDIR}/.."; pwd)"
|
||||
wsl=false
|
||||
darwin=false
|
||||
cygwin=false
|
||||
linux=false
|
||||
platform=unknown
|
||||
|
||||
if [ "$(uname)" = "Darwin" ]
|
||||
then
|
||||
darwin=true
|
||||
platform=darwin
|
||||
elif [ "$(uname -s | head --bytes 6)" = "CYGWIN" ]
|
||||
then
|
||||
cygwin=true
|
||||
platform=cgwin
|
||||
elif [ -e "/proc/version" ] && grep --ignore-case --quiet Microsoft /proc/version
|
||||
then
|
||||
platform=wsl
|
||||
wsl=true
|
||||
wsl_ver=0
|
||||
# WSL2
|
||||
@@ -161,7 +166,19 @@ Exiting"
|
||||
fi
|
||||
fi
|
||||
fi
|
||||
else
|
||||
linux=true
|
||||
platform=linux
|
||||
fi
|
||||
#################### TEST CODE ####################
|
||||
|
||||
#wsl=false
|
||||
#darwin=false
|
||||
#cygwin=false
|
||||
#linux=true
|
||||
#platform=linux
|
||||
|
||||
#################### TEST CODE ####################
|
||||
|
||||
# process config file and args
|
||||
# shellcheck source=./medley_configfile.sh
|
||||
|
||||
@@ -327,9 +327,9 @@ fi
|
||||
|
||||
|
||||
# Run maiko either directly or with vnc
|
||||
if [ "${wsl}" = true ] && [ "${use_vnc}" = true ]
|
||||
if [ "${use_vnc}" = true ]
|
||||
then
|
||||
# do the vnc thing on wsl (if called for)
|
||||
# do the vnc thing - if called for
|
||||
# shellcheck source=./medley_vnc.sh
|
||||
. "${SCRIPTDIR}/medley_vnc.sh"
|
||||
else
|
||||
|
||||
@@ -98,8 +98,8 @@ flags:
|
||||
-t STRING | --title STRING : use STRING as title of window
|
||||
|
||||
-d :N | --display :N : use X display :N
|
||||
+w
|
||||
+w -v | --vnc : (WSL only) Use a VNC window instead of an X window
|
||||
|
||||
-v | --vnc : Use a VNC window instead of an X window (Not available: MacOS & Windows/Cygwin)
|
||||
|
||||
-i STRING | --id STRING : use STRING as the id for this run of Medley (default: default)
|
||||
|
||||
|
||||
@@ -16,9 +16,14 @@
|
||||
# Copyright 2023 Interlisp.org
|
||||
#
|
||||
###############################################################################
|
||||
|
||||
#set -x
|
||||
ip_addr() {
|
||||
ip -4 -br address show dev eth0 | awk '{print $3}' | sed 's-/.*$--'
|
||||
if [ "${wsl}" = true ]
|
||||
then
|
||||
ip -4 -br address show dev eth0 | awk '{print $3}' | sed 's-/.*$--'
|
||||
else
|
||||
echo "127.0.0.1"
|
||||
fi
|
||||
}
|
||||
|
||||
find_open_display() {
|
||||
@@ -60,21 +65,39 @@
|
||||
}
|
||||
|
||||
#
|
||||
# Make sure prequisites for vnc support in wsl are in place
|
||||
# Make sure prequisites for vnc support are in place
|
||||
#
|
||||
if [ "${use_vnc}" = "true" ];
|
||||
if [ -z "$(which Xvnc)" ] || [ "$(Xvnc -version 2>&1 | grep -iq tigervnc; echo $?)" -eq 1 ]
|
||||
then
|
||||
echo "Error: The -v or --vnc flag was set."
|
||||
echo "But it appears that that TigerVNC server \(Xvnc\) has not been installed."
|
||||
echo "Please install the TigerVNC server and try again. On Debian and Ubuntu, use:"
|
||||
echo "\"sudo apt install tigervnc-standalone-server\". On most other Linux distros, use the"
|
||||
echo "distro's package manager to install the \"tigervnc-server\" package."
|
||||
echo "Exiting."
|
||||
exit 4
|
||||
fi
|
||||
if [ "${linux}" = "true" ]
|
||||
then
|
||||
if [ -z "$(which vncviewer)" ] || [ "$(vncviewer -v 2>&1 | head -2 | grep -iq tigervnc; echo $?)" -eq 1 ]
|
||||
then
|
||||
echo "Error: The -v or --vnc flag was set."
|
||||
echo "But it appears that that the TigerVNC viewer \(vncviewer\) is not installed on your system."
|
||||
echo "Please install the TigerVNC viewer and try again. On Debian and Ubuntu, use:"
|
||||
echo "\"sudo apt install tigervnc-viewer\". On most other Linux distros, use the"
|
||||
echo "the distro's package manager to install the \"tigervnc-viewer\" (or sometimes just \"tigervnc\")"
|
||||
echo "package."
|
||||
echo "Exiting."
|
||||
exit 5
|
||||
else
|
||||
vncviewer="$(which vncviewer)"
|
||||
fi
|
||||
elif [ "${wsl}" = "true" ]
|
||||
then
|
||||
win_userprofile="$(cmd.exe /c "<nul set /p=%UserProfile%" 2>/dev/null)"
|
||||
vnc_dir="$(wslpath "${win_userprofile}")/AppData/Local/Interlisp"
|
||||
vnc_exe="vncviewer64-1.12.0.exe"
|
||||
if [ "$(which Xvnc)" = "" ] || [ "$(Xvnc -version 2>&1 | grep -iq tigervnc; echo $?)" -eq 1 ]
|
||||
then
|
||||
echo "Error: The -v or --vnc flag was set."
|
||||
echo "But it appears that that TigerVNC \(Xvnc\) has not been installed."
|
||||
echo "Please install TigerVNC using \"sudo apt install tigervnc-standalone-server tigervnc-xorg-extension\""
|
||||
echo "Exiting."
|
||||
exit 4
|
||||
elif [ ! -e "${vnc_dir}/${vnc_exe}" ];
|
||||
if [ ! -e "${vnc_dir}/${vnc_exe}" ];
|
||||
then
|
||||
if [ -e "${IL_DIR}/wsl/${vnc_exe}" ];
|
||||
then
|
||||
@@ -108,6 +131,7 @@
|
||||
done
|
||||
fi
|
||||
fi
|
||||
vncviewer="${vnc_dir}/${vnc_exe}"
|
||||
fi
|
||||
#
|
||||
# Start the log file so we can trace any issues with vnc, etc
|
||||
@@ -127,6 +151,7 @@
|
||||
# find an unused display and an available port
|
||||
#
|
||||
#set -x
|
||||
ORIGINAL_DISPLAY="${DISPLAY}"
|
||||
OPEN_DISPLAY="$(find_open_display)"
|
||||
if [ "${OPEN_DISPLAY}" -eq -1 ];
|
||||
then
|
||||
@@ -153,15 +178,15 @@
|
||||
# Start the Xvnc server
|
||||
#
|
||||
mkdir -p "${LOGINDIR}"/logs
|
||||
/usr/bin/Xvnc "${DISPLAY}" \
|
||||
-rfbport "${VNC_PORT}" \
|
||||
-geometry "${geometry}" \
|
||||
-SecurityTypes None \
|
||||
-NeverShared \
|
||||
-DisconnectClients=0 \
|
||||
-desktop "${title}" \
|
||||
--MaxDisconnectionTime=10 \
|
||||
>> "${LOG}" 2>&1 &
|
||||
Xvnc "${DISPLAY}" \
|
||||
-rfbport "${VNC_PORT}" \
|
||||
-geometry "${geometry}" \
|
||||
-SecurityTypes None \
|
||||
-NeverShared \
|
||||
-DisconnectClients=0 \
|
||||
-desktop "${title}" \
|
||||
--MaxDisconnectionTime=10 \
|
||||
>> "${LOG}" 2>&1 &
|
||||
|
||||
sleep .5
|
||||
#
|
||||
@@ -171,25 +196,24 @@
|
||||
start_maiko "$@"
|
||||
if [ -n "$(pgrep -f "${vnc_exe}.*:${VNC_PORT}")" ]; then vncconfig -disconnect; fi
|
||||
} &
|
||||
|
||||
#
|
||||
# Start the vncviewer on the windows side
|
||||
# Start the vncviewer
|
||||
#
|
||||
|
||||
# First give medley time to startup
|
||||
# sleep .25
|
||||
# SLeep appears not to be needed, but faster/slower machines ????
|
||||
# Sleep appears not to be needed, but faster/slower machines ????
|
||||
# FGH 2023-02-08
|
||||
|
||||
# Then start vnc viewer on Windows side
|
||||
# Then start vnc viewer
|
||||
vncv_loc=$(( OPEN_DISPLAY * 50 ))
|
||||
start_time=$(date +%s)
|
||||
"${vnc_dir}"/${vnc_exe} \
|
||||
-geometry "+${vncv_loc}+${vncv_loc}" \
|
||||
-ReconnectOnError=off \
|
||||
−AlertOnFatalError=off \
|
||||
"$(ip_addr)":"${VNC_PORT}" \
|
||||
>>"${LOG}" 2>&1 &
|
||||
export DISPLAY="${ORIGINAL_DISPLAY}"
|
||||
"${vncviewer}" -geometry "+${vncv_loc}+${vncv_loc}" \
|
||||
−AlertOnFatalError=0 \
|
||||
-ReconnectOnError=0 \
|
||||
"$(ip_addr)":"${VNC_PORT}" \
|
||||
>>"${LOG}" 2>&1 &
|
||||
wait $!
|
||||
if [ $(( $(date +%s) - start_time )) -lt 5 ]
|
||||
then
|
||||
|
||||
@@ -1,17 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "19-Jul-2022 23:31:31"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>sources>CMLREAD.;15 12803
|
||||
(FILECREATED "23-Sep-2024 11:55:33" {DSK}<home>matt>Interlisp>medley>sources>CMLREAD.;4 12882
|
||||
|
||||
:CHANGES-TO (FNS CL:PEEK-CHAR)
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:PREVIOUS-DATE "16-Aug-2021 23:42:49"
|
||||
{DSK}<users>kaplan>local>medley3.5>working-medley>sources>CMLREAD.;14)
|
||||
:CHANGES-TO (FNS CL:READ-FROM-STRING)
|
||||
|
||||
:PREVIOUS-DATE "16-Sep-2024 12:26:09" {DSK}<home>matt>Interlisp>medley>sources>CMLREAD.;3)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1985-1988, 1990, 1993, 2021 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT CMLREADCOMS)
|
||||
|
||||
@@ -188,16 +184,19 @@ Copyright (c) 1985-1988, 1990, 1993, 2021 by Venue & Xerox Corporation.
|
||||
|
||||
(CL:READ-FROM-STRING
|
||||
[CL:LAMBDA (STRING &OPTIONAL EOF-ERROR-P EOF-VALUE &KEY START END PRESERVE-WHITESPACE)
|
||||
(* ; "Edited 23-Sep-2024 11:47 by mth")
|
||||
(* ; "Edited 16-Sep-2024 12:22 by mth")
|
||||
(* ; "Edited 8-Jun-90 14:15 by ymasuda")
|
||||
(LET [(STREAM (OPENSTRINGSTREAM (COND
|
||||
[END (SUBSTRING STRING 1 (IMIN END (NCHARS STRING]
|
||||
(T (MKSTRING STRING]
|
||||
(COND
|
||||
(START (SETFILEPTR STREAM START)))
|
||||
[COND
|
||||
(START (SETFILEPTR STREAM (UNFOLD START 2]
|
||||
(CL:VALUES (CL:IF PRESERVE-WHITESPACE
|
||||
(CL:READ-PRESERVING-WHITESPACE STREAM EOF-ERROR-P EOF-VALUE)
|
||||
(CL:READ STREAM EOF-ERROR-P EOF-VALUE))
|
||||
(\GETFILEPTR STREAM])
|
||||
(FOLDLO (\GETFILEPTR STREAM)
|
||||
2])
|
||||
|
||||
(CL:READ-BYTE
|
||||
[CL:LAMBDA (BINARY-INPUT-STREAM &OPTIONAL (EOF-ERRORP T)
|
||||
@@ -287,11 +286,10 @@ Copyright (c) 1985-1988, 1990, 1993, 2021 by Venue & Xerox Corporation.
|
||||
(ADDTOVAR LAMA CL:READ-BYTE CL:READ-FROM-STRING CL:CLEAR-INPUT CL:READ-CHAR-NO-HANG CL:PEEK-CHAR
|
||||
CL:UNREAD-CHAR CL:READ-CHAR CL:READ-LINE CL:COPY-READTABLE)
|
||||
)
|
||||
(PUTPROPS CMLREAD COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1993 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (2525 3510 (CL:COPY-READTABLE 2535 . 3508)) (3511 10454 (CL:READ-LINE 3521 . 4393) (
|
||||
CL:READ-CHAR 4395 . 4945) (CL:UNREAD-CHAR 4947 . 5408) (CL:PEEK-CHAR 5410 . 7704) (CL:LISTEN 7706 .
|
||||
7971) (CL:READ-CHAR-NO-HANG 7973 . 8745) (CL:CLEAR-INPUT 8747 . 8984) (CL:READ-FROM-STRING 8986 . 9741
|
||||
) (CL:READ-BYTE 9743 . 10196) (CL:WRITE-BYTE 10198 . 10452)) (11448 11921 (WITH-READER-ENVIRONMENT
|
||||
11448 . 11921)))))
|
||||
(FILEMAP (NIL (2433 3418 (CL:COPY-READTABLE 2443 . 3416)) (3419 10627 (CL:READ-LINE 3429 . 4301) (
|
||||
CL:READ-CHAR 4303 . 4853) (CL:UNREAD-CHAR 4855 . 5316) (CL:PEEK-CHAR 5318 . 7612) (CL:LISTEN 7614 .
|
||||
7879) (CL:READ-CHAR-NO-HANG 7881 . 8653) (CL:CLEAR-INPUT 8655 . 8892) (CL:READ-FROM-STRING 8894 . 9914
|
||||
) (CL:READ-BYTE 9916 . 10369) (CL:WRITE-BYTE 10371 . 10625)) (11621 12094 (WITH-READER-ENVIRONMENT
|
||||
11621 . 12094)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
196
sources/CMLTYPES
196
sources/CMLTYPES
@@ -1,15 +1,20 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "LISP")
|
||||
(IL:FILECREATED " 4-Jan-93 17:55:42" IL:|{DSK}<python>lde>lispcore>sources>CMLTYPES.;2| 66088
|
||||
(DEFINE-FILE-INFO PACKAGE "LISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
IL:|previous| IL:|date:| "16-May-90 14:50:29" IL:|{DSK}<python>lde>lispcore>sources>CMLTYPES.;1|
|
||||
(IL:FILECREATED " 4-Jun-2024 23:32:50" IL:|{DSK}<home>matt>Interlisp>medley>SOURCES>CMLTYPES.;2| 66046
|
||||
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (IL:FUNCTIONS SYMBOL-TYPE)
|
||||
|
||||
:PREVIOUS-DATE " 4-Jan-93 17:55:42" IL:|{DSK}<home>matt>Interlisp>medley>SOURCES>CMLTYPES.;1|
|
||||
)
|
||||
|
||||
|
||||
; Copyright (c) 1985, 1986, 1987, 1988, 1990, 1993 by Venue & Xerox Corporation. All rights reserved.
|
||||
; Copyright (c) 1985-1988, 1990, 1993, 2024 by Venue & Xerox Corporation.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:CMLTYPESCOMS)
|
||||
|
||||
(IL:RPAQQ IL:CMLTYPESCOMS
|
||||
(IL:RPAQQ IL:CMLTYPESCOMS
|
||||
(
|
||||
|
||||
(IL:* IL:|;;;| "Implementation of Common Lisp type system. ")
|
||||
@@ -137,8 +142,8 @@
|
||||
(IL:* IL:|;;| "Check if OBJECT is of type TYPE")
|
||||
|
||||
(LET* ((SYMBOL-TYPE (IF (CONSP TYPE)
|
||||
(CAR TYPE)
|
||||
TYPE))
|
||||
(CAR TYPE)
|
||||
TYPE))
|
||||
(FN (GETHASH SYMBOL-TYPE *TYPEP-HASH-TABLE*)))
|
||||
(IF FN
|
||||
(IF (CONSP TYPE)
|
||||
@@ -174,8 +179,7 @@
|
||||
(ERROR "Unknown type expression: ~s" TYPE)))))))))
|
||||
|
||||
(DEFUN TYPE-OF (X)
|
||||
(LET ((TYPENAME (IL:\\INDEXATOMPNAME (IL:|fetch| IL:DTDNAME IL:|of| (IL:\\GETDTD
|
||||
(IL:NTYPX X))))))
|
||||
(LET ((TYPENAME (IL:\\INDEXATOMPNAME (IL:|fetch| IL:DTDNAME IL:|of| (IL:\\GETDTD (IL:NTYPX X))))))
|
||||
(SETQ TYPENAME (OR (GET TYPENAME 'CMLTYPE)
|
||||
TYPENAME))
|
||||
(OR (LET ((D (GET TYPENAME 'CMLSUBTYPE-DESCRIMINATOR)))
|
||||
@@ -245,27 +249,27 @@
|
||||
(NULL TYPE))))
|
||||
|
||||
(XCL:DEFOPTIMIZER TYPEP (OBJ TYPE)
|
||||
(IF (CONSTANTP TYPE)
|
||||
(LET ((TYPE-EXPR (EVAL TYPE)))
|
||||
(IF (%VALID-TYPE-P TYPE-EXPR)
|
||||
`(,(%TYPEP-PRED TYPE-EXPR)
|
||||
,OBJ)
|
||||
(PROGN (WARN "Can't optimize (typep ~s ~s); type not known."
|
||||
OBJ TYPE)
|
||||
'COMPILER:PASS)))
|
||||
'COMPILER:PASS))
|
||||
(IF (CONSTANTP TYPE)
|
||||
(LET ((TYPE-EXPR (EVAL TYPE)))
|
||||
(IF (%VALID-TYPE-P TYPE-EXPR)
|
||||
`(,(%TYPEP-PRED TYPE-EXPR)
|
||||
,OBJ)
|
||||
(PROGN (WARN "Can't optimize (typep ~s ~s); type not known." OBJ
|
||||
TYPE)
|
||||
'COMPILER:PASS)))
|
||||
'COMPILER:PASS))
|
||||
|
||||
(XCL:DEFOPTIMIZER COERCE (OBJECT RESULT-TYPE)
|
||||
|
||||
(IL:* IL:|;;| "Open code the simple coerce cases ")
|
||||
(IL:* IL:|;;| "Open code the simple coerce cases ")
|
||||
|
||||
(IF (CONSTANTP RESULT-TYPE)
|
||||
(CASE (EVAL RESULT-TYPE)
|
||||
(CHARACTER `(CHARACTER ,OBJECT))
|
||||
((FLOAT SINGLE-FLOAT SHORT-FLOAT LONG-FLOAT DOUBLE-FLOAT)
|
||||
`(FLOAT ,OBJECT))
|
||||
(OTHERWISE 'COMPILER:PASS))
|
||||
'COMPILER:PASS))
|
||||
(IF (CONSTANTP RESULT-TYPE)
|
||||
(CASE (EVAL RESULT-TYPE)
|
||||
(CHARACTER `(CHARACTER ,OBJECT))
|
||||
((FLOAT SINGLE-FLOAT SHORT-FLOAT LONG-FLOAT DOUBLE-FLOAT)
|
||||
`(FLOAT ,OBJECT))
|
||||
(OTHERWISE 'COMPILER:PASS))
|
||||
'COMPILER:PASS))
|
||||
|
||||
|
||||
|
||||
@@ -275,10 +279,10 @@
|
||||
(XCL:DEF-DEFINE-TYPE IL:TYPES "Common Lisp type definitions")
|
||||
|
||||
(XCL:DEFDEFINER (DEFTYPE (:PROTOTYPE (LAMBDA (NAME)
|
||||
(AND (SYMBOLP NAME)
|
||||
`(DEFTYPE ,NAME ("Arg list")
|
||||
"Body"))))) IL:TYPES (NAME DEFTYPE-ARGS
|
||||
&BODY BODY)
|
||||
(AND (SYMBOLP NAME)
|
||||
`(DEFTYPE ,NAME ("Arg list")
|
||||
"Body"))))) IL:TYPES (NAME DEFTYPE-ARGS &BODY
|
||||
BODY)
|
||||
(UNLESS (AND NAME (SYMBOLP NAME))
|
||||
(ERROR "Illegal name used in DEFTYPE: ~S" NAME))
|
||||
(LET
|
||||
@@ -321,8 +325,8 @@
|
||||
|
||||
(DEFUN TYPE-EXPANDER (TYPE)
|
||||
(LET* ((SYMBOL-TYPE (ETYPECASE TYPE
|
||||
(SYMBOL TYPE)
|
||||
(CONS (CAR TYPE))))
|
||||
(SYMBOL TYPE)
|
||||
(CONS (CAR TYPE))))
|
||||
(EXPANDER (OR (GET SYMBOL-TYPE ':TYPE-EXPANDER)
|
||||
(GET SYMBOL-TYPE 'IL:TYPE-EXPANDER))))
|
||||
(IF (AND (NULL EXPANDER)
|
||||
@@ -342,7 +346,7 @@
|
||||
(IL:FILEPKGFLG NIL)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"DFNFLG nil makes sure this has an effect and filepkgflg nil makes sure it isn't remembered.")
|
||||
"DFNFLG nil makes sure this has an effect and filepkgflg nil makes sure it isn't remembered.")
|
||||
|
||||
)
|
||||
(EVAL DEFTYPE-FORM)))
|
||||
@@ -394,10 +398,13 @@
|
||||
(LIST 'ARRAY (ARRAY-ELEMENT-TYPE ARRAY)
|
||||
(ARRAY-DIMENSIONS ARRAY))))))
|
||||
|
||||
(DEFUN SYMBOL-TYPE (SYMBOL)
|
||||
(IF (KEYWORDP SYMBOL)
|
||||
'KEYWORD
|
||||
'SYMBOL))
|
||||
(DEFUN SYMBOL-TYPE (SYMBOL) (IL:* IL:\; "Edited 4-Jun-2024 23:23 by mth")
|
||||
(COND
|
||||
((NULL SYMBOL)
|
||||
'NULL)
|
||||
((KEYWORDP SYMBOL)
|
||||
'KEYWORD)
|
||||
(T 'SYMBOL)))
|
||||
|
||||
(DEFUN XCL:FALSE ()
|
||||
NIL)
|
||||
@@ -474,18 +481,18 @@
|
||||
T))
|
||||
|
||||
(XCL:DEFOPTIMIZER NUMBERP (X)
|
||||
`(AND (IL:NUMBERP ,X)
|
||||
T))
|
||||
`(AND (IL:NUMBERP ,X)
|
||||
T))
|
||||
|
||||
(XCL:DEFOPTIMIZER FLOATP (X)
|
||||
`(AND (IL:FLOATP ,X)
|
||||
T))
|
||||
`(AND (IL:FLOATP ,X)
|
||||
T))
|
||||
|
||||
(XCL:DEFOPTIMIZER XCL:FALSE (&BODY IL:FORMS)
|
||||
`(PROG1 NIL ,@IL:FORMS))
|
||||
`(PROG1 NIL ,@IL:FORMS))
|
||||
|
||||
(XCL:DEFOPTIMIZER XCL:TRUE (&BODY XCL::FORMS)
|
||||
`(PROG1 T ,@XCL::FORMS))
|
||||
`(PROG1 T ,@XCL::FORMS))
|
||||
|
||||
|
||||
|
||||
@@ -546,7 +553,7 @@
|
||||
(DEFCONSTANT *COMMON-LISP-BASE-TYPES*
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"The types which are known to be disjoint from any type explicitly handled by subtypep.")
|
||||
"The types which are known to be disjoint from any type explicitly handled by subtypep.")
|
||||
|
||||
'(
|
||||
(IL:* IL:|;;| "The only types that need to be in this list are types on page 43 that expand into a satisfies or datatype clause, i.e. any type that expands into something that base-subtypep doesn't know to handle, e.g. satisfies.")
|
||||
@@ -554,10 +561,10 @@
|
||||
ARRAY ATOM BIGNUM (IL:* IL:\; "even though bignum expands into a datatype, that datatype is not a subdatatype of integer, etc. so must be explicitly handled.")
|
||||
CHARACTER COMMON COMPLEX COMPILED-FUNCTION CONS IL:DATATYPE
|
||||
(IL:* IL:\;
|
||||
"this is only here for back-compatibility. The first global recompile, this can go.")
|
||||
"this is only here for back-compatibility. The first global recompile, this can go.")
|
||||
:DATATYPE FLOAT FUNCTION HASH-TABLE INTEGER KEYWORD NIL NULL NUMBER PACKAGE PATHNAME
|
||||
RANDOM-STATE RATIO (IL:* IL:\;
|
||||
"same comment for ratio as bignum.")
|
||||
"same comment for ratio as bignum.")
|
||||
RATIONAL READTABLE SIMPLE-ARRAY STANDARD-CHAR STREAM STRING-CHAR SYMBOL T))
|
||||
|
||||
(DEFCONSTANT *BASE-TYPE-LATTICE*
|
||||
@@ -572,14 +579,14 @@
|
||||
#'COMPILED-FUNCTION
|
||||
(NIL)
|
||||
(IL:DATATYPE :DATATYPE) (IL:* IL:\;
|
||||
"the presence of il:datatype is for back compatibility.")
|
||||
"the presence of il:datatype is for back compatibility.")
|
||||
(:DATATYPE IL:DATATYPE))
|
||||
"the lattice which tells the (base) subtypes of any base type.")
|
||||
|
||||
(DEFUN SUBTYPEP (TYPE1 TYPE2)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Returns T if type1 is a subtype of type2. If second value is nil, couldn't decide.")
|
||||
"Returns T if type1 is a subtype of type2. If second value is nil, couldn't decide.")
|
||||
|
||||
(IF (EQUAL TYPE1 TYPE2)
|
||||
|
||||
@@ -608,7 +615,7 @@
|
||||
(OR
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"(subtypep '(or t1 t2 ...) 't3) <=> (and (subtypep 't1 't3) (subtypep 't2 't3) ...)")
|
||||
"(subtypep '(or t1 t2 ...) 't3) <=> (and (subtypep 't1 't3) (subtypep 't2 't3) ...)")
|
||||
|
||||
(LET ((RESULT T)
|
||||
CERTAINTY
|
||||
@@ -628,7 +635,7 @@
|
||||
(RETURN T)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"else continue to look for a more cetain result")
|
||||
"else continue to look for a more cetain result")
|
||||
|
||||
(SETQ LOOP-CERTAINTY NIL)))
|
||||
(T (IF (NULL CONJUNCT-CERTAINTY)
|
||||
@@ -669,7 +676,7 @@
|
||||
(RETURN T)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"else continue to look for a more cetain result")
|
||||
"else continue to look for a more cetain result")
|
||||
|
||||
(SETQ LOOP-CERTAINTY NIL)))
|
||||
(T (IF (NULL CONJUNCT-CERTAINTY)
|
||||
@@ -680,7 +687,7 @@
|
||||
(IL:* IL:|;;| "(subtypep 't1 '(or t2 t3 ...)) <=> (or (subtypep 't1 't2) (subtypep 't1 't3) ... ) because '(or t1 t2 ...) denotes the union of types t1, t2, ...")
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"We can't ever return (values nil t) because the t2..tn might form a partition of t1, i.e.")
|
||||
"We can't ever return (values nil t) because the t2..tn might form a partition of t1, i.e.")
|
||||
|
||||
(IL:* IL:|;;| "(deftype evenp nil '(and integer (satisfies %evenp)))")
|
||||
|
||||
@@ -709,7 +716,7 @@
|
||||
(SUBTYPEP TYPE1 NEW-TYPE2)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"we have now handled everything but base types. There is no further expansion etc, to be done.")
|
||||
"we have now handled everything but base types. There is no further expansion etc, to be done.")
|
||||
|
||||
(BASE-SUBTYPEP TYPE1 TYPE2)))))))))))
|
||||
|
||||
@@ -737,10 +744,9 @@
|
||||
|
||||
(DO* ((TYPE-NUMBER-1 (IL:\\TYPENUMBERFROMNAME TYPE1))
|
||||
(TYPE-NUMBER-2 (IL:\\TYPENUMBERFROMNAME TYPE2))
|
||||
(SUPER-TYPE-NUMBER TYPE-NUMBER-1 (IL:|fetch| IL:DTDSUPERTYPE IL:|of| (IL:\\GETDTD
|
||||
|
||||
(SUPER-TYPE-NUMBER TYPE-NUMBER-1 (IL:|fetch| IL:DTDSUPERTYPE IL:|of| (IL:\\GETDTD
|
||||
SUPER-TYPE-NUMBER
|
||||
))))
|
||||
))))
|
||||
((EQ %NO-SUPER-TYPE SUPER-TYPE-NUMBER)
|
||||
|
||||
(IL:* IL:|;;| "we didn't find type2 on type1's super chain so return NIL ")
|
||||
@@ -752,7 +758,7 @@
|
||||
(DEFUN EQUAL-DIMENSIONS (DIMS1 DIMS2)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Says if dims1 and dims2 are the same in each dimension (allowing for wildcard's (*'s)).")
|
||||
"Says if dims1 and dims2 are the same in each dimension (allowing for wildcard's (*'s)).")
|
||||
|
||||
(OR (EQ DIMS1 '*)
|
||||
(EQ DIMS2 '*)
|
||||
@@ -784,12 +790,12 @@
|
||||
TYPE
|
||||
(LIST TYPE))))
|
||||
(CASE (CAR LIST-TYPE)
|
||||
((SIMPLE-ARRAY ARRAY) (XCL:DESTRUCTURING-BIND (ARRAY-TYPE &OPTIONAL
|
||||
(ELEMENT-TYPE '*)
|
||||
((SIMPLE-ARRAY ARRAY) (XCL:DESTRUCTURING-BIND (ARRAY-TYPE &OPTIONAL (ELEMENT-TYPE
|
||||
'*)
|
||||
(DIMENSIONS '*))
|
||||
LIST-TYPE
|
||||
(LIST ARRAY-TYPE ELEMENT-TYPE (
|
||||
COMPLETE-ARRAY-TYPE-DIMENSIONS
|
||||
COMPLETE-ARRAY-TYPE-DIMENSIONS
|
||||
DIMENSIONS))))
|
||||
((INTEGER FLOAT RATIONAL) (XCL:DESTRUCTURING-BIND (NUMERIC-TYPE &OPTIONAL
|
||||
(LOWER '*)
|
||||
@@ -886,17 +892,17 @@
|
||||
(IL:* IL:|;;| "from this point on, we are only dealing with Common Lisp base types.")
|
||||
|
||||
((EQ TYPE1 T) (IL:* IL:\;
|
||||
"t is not a subtype of anything but t, and that's checked above).")
|
||||
"t is not a subtype of anything but t, and that's checked above).")
|
||||
(VALUES NIL T))
|
||||
((EQ TYPE2 NIL) (IL:* IL:\;
|
||||
"nil is not a supertype of anything but nil, and that's checked above).")
|
||||
"nil is not a supertype of anything but nil, and that's checked above).")
|
||||
(VALUES NIL T))
|
||||
((EQ TYPE2 'ATOM)
|
||||
|
||||
(IL:* IL:|;;| "this case could be explicitly added to the type lattice. But if someone adds a base type, then they would have to remember to add it as a sub type of atom, (which they wouldn't.)")
|
||||
|
||||
(IF (EQ TYPE1 'CONS) (IL:* IL:\;
|
||||
"this is the only base type that isn't a subtype of atom.")
|
||||
"this is the only base type that isn't a subtype of atom.")
|
||||
(VALUES NIL T)
|
||||
(VALUES T T)))
|
||||
((NOT (OR (EQ SYMBOL-TYPE1 SYMBOL-TYPE2)
|
||||
@@ -918,14 +924,13 @@
|
||||
((ARRAY SIMPLE-ARRAY)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"the type will look like (simple-array element-type dimensions)")
|
||||
"the type will look like (simple-array element-type dimensions)")
|
||||
|
||||
(XCL:DESTRUCTURING-BIND (ARRAY-TYPE1 ELEMENT-TYPE-1 DIMS-1)
|
||||
TYPE1
|
||||
(XCL:DESTRUCTURING-BIND (ARRAY-TYPE2 ELEMENT-TYPE-2 DIMS-2)
|
||||
TYPE2
|
||||
(IF (AND (EQUAL-ELEMENT-TYPE ELEMENT-TYPE-1
|
||||
ELEMENT-TYPE-2)
|
||||
(IF (AND (EQUAL-ELEMENT-TYPE ELEMENT-TYPE-1 ELEMENT-TYPE-2)
|
||||
(EQUAL-DIMENSIONS DIMS-1 DIMS-2))
|
||||
(VALUES T T)
|
||||
(VALUES NIL T)))))
|
||||
@@ -940,7 +945,7 @@
|
||||
(NUMBER
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"number doesn't take ranges, there's nothing to verify.")
|
||||
"number doesn't take ranges, there's nothing to verify.")
|
||||
|
||||
(VALUES T T))
|
||||
(OTHERWISE (XCL:DESTRUCTURING-BIND
|
||||
@@ -949,8 +954,8 @@
|
||||
(XCL:DESTRUCTURING-BIND
|
||||
(NUMERIC-TYPE2 LOW2 HIGH2)
|
||||
TYPE2
|
||||
(IF (RANGE<= LOW2 LOW1 HIGH1
|
||||
HIGH2 NUMERIC-TYPE1
|
||||
(IF (RANGE<= LOW2 LOW1 HIGH1 HIGH2
|
||||
NUMERIC-TYPE1
|
||||
NUMERIC-TYPE2)
|
||||
(VALUES T T)
|
||||
(VALUES NIL T)))))))
|
||||
@@ -1220,7 +1225,7 @@
|
||||
(DEFTYPE VECTOR (&OPTIONAL ELEMENT-TYPE SIZE)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"this type must be defined in terms of array so that subtypep can reason(?) about them.")
|
||||
"this type must be defined in terms of array so that subtypep can reason(?) about them.")
|
||||
|
||||
`(ARRAY ,ELEMENT-TYPE (,SIZE)))
|
||||
|
||||
@@ -1351,7 +1356,7 @@
|
||||
(SYMBOL-PACKAGE NAME))))
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"the eval-when insures that the functions in the hash table are always compiled")
|
||||
"the eval-when insures that the functions in the hash table are always compiled")
|
||||
|
||||
`(PROGN (EVAL-WHEN (LOAD)
|
||||
(SETF (SYMBOL-FUNCTION ',TYPEP-NAME)
|
||||
@@ -1582,54 +1587,67 @@
|
||||
(IL:* IL:|;;;| "for TYPE-OF Interlisp types that have different common Lisp names")
|
||||
|
||||
|
||||
(IL:PUTPROPS IL:CHARACTER CMLTYPE CHARACTER)
|
||||
(IL:PUTPROPS IL:CHARACTER CMLTYPE CHARACTER)
|
||||
|
||||
(IL:PUTPROPS IL:FIXP CMLTYPE BIGNUM)
|
||||
(IL:PUTPROPS IL:FIXP CMLTYPE BIGNUM)
|
||||
|
||||
(IL:PUTPROPS IL:FLOATP CMLTYPE SINGLE-FLOAT)
|
||||
(IL:PUTPROPS IL:FLOATP CMLTYPE SINGLE-FLOAT)
|
||||
|
||||
(IL:PUTPROPS IL:GENERAL-ARRAY CMLTYPE ARRAY)
|
||||
(IL:PUTPROPS IL:GENERAL-ARRAY CMLTYPE ARRAY)
|
||||
|
||||
(IL:PUTPROPS IL:LISTP CMLTYPE CONS)
|
||||
(IL:PUTPROPS IL:LISTP CMLTYPE CONS)
|
||||
|
||||
(IL:PUTPROPS IL:LITATOM CMLTYPE SYMBOL)
|
||||
(IL:PUTPROPS IL:LITATOM CMLTYPE SYMBOL)
|
||||
|
||||
(IL:PUTPROPS IL:ONED-ARRAY CMLTYPE ARRAY)
|
||||
(IL:PUTPROPS IL:ONED-ARRAY CMLTYPE ARRAY)
|
||||
|
||||
(IL:PUTPROPS IL:SMALLP CMLTYPE FIXNUM)
|
||||
(IL:PUTPROPS IL:SMALLP CMLTYPE FIXNUM)
|
||||
|
||||
(IL:PUTPROPS IL:HARRAYP CMLTYPE HASH-TABLE)
|
||||
(IL:PUTPROPS IL:HARRAYP CMLTYPE HASH-TABLE)
|
||||
|
||||
(IL:PUTPROPS IL:TWOD-ARRAY CMLTYPE ARRAY)
|
||||
(IL:PUTPROPS IL:TWOD-ARRAY CMLTYPE ARRAY)
|
||||
|
||||
(IL:PUTPROPS SYMBOL CMLSUBTYPE-DESCRIMINATOR SYMBOL-TYPE)
|
||||
(IL:PUTPROPS SYMBOL CMLSUBTYPE-DESCRIMINATOR SYMBOL-TYPE)
|
||||
|
||||
(IL:PUTPROPS ARRAY CMLSUBTYPE-DESCRIMINATOR ARRAY-TYPE)
|
||||
(IL:PUTPROPS ARRAY CMLSUBTYPE-DESCRIMINATOR ARRAY-TYPE)
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;;| "tell the filepkg what to do with the type-expander property")
|
||||
|
||||
|
||||
(IL:PUTPROPS :TYPE-EXPANDER IL:PROPTYPE IGNORE)
|
||||
(IL:PUTPROPS :TYPE-EXPANDER IL:PROPTYPE IGNORE)
|
||||
|
||||
(IL:PUTPROPS IL:TYPE-EXPANDER IL:PROPTYPE IGNORE)
|
||||
(IL:PUTPROPS IL:TYPE-EXPANDER IL:PROPTYPE IGNORE)
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;;| "Compiler options")
|
||||
|
||||
|
||||
(IL:PUTPROPS IL:CMLTYPES IL:FILETYPE COMPILE-FILE)
|
||||
(IL:PUTPROPS IL:CMLTYPES IL:FILETYPE COMPILE-FILE)
|
||||
|
||||
(IL:PUTPROPS IL:CMLTYPES IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
|
||||
(IL:PUTPROPS IL:CMLTYPES IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "LISP"))
|
||||
(IL:DECLARE\: IL:DONTEVAL@LOAD IL:DOEVAL@COMPILE IL:DONTCOPY
|
||||
(IL:DECLARE\: IL:DOEVAL@COMPILE IL:DONTCOPY
|
||||
|
||||
(IL:LOCALVARS . T)
|
||||
)
|
||||
)
|
||||
(IL:PUTPROPS IL:CMLTYPES IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1993))
|
||||
(IL:PUTPROPS IL:CMLTYPES IL:COPYRIGHT ("Venue & Xerox Corporation" 1985 1986 1987 1988 1990 1993 2024)
|
||||
)
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL)))
|
||||
(IL:FILEMAP (NIL (4086 4144 (COMMONP 4086 . 4144)) (4257 6153 (TYPEP 4257 . 6153)) (6155 6504 (TYPE-OF
|
||||
6155 . 6504)) (6506 7652 (COERCE 6506 . 7652)) (7654 8477 (TYPECASE 7654 . 8477)) (8479 8916 (
|
||||
%VALID-TYPE-P 8479 . 8916)) (12020 12451 (TYPE-EXPAND 12020 . 12451)) (12453 13582 (TYPE-EXPANDER
|
||||
12453 . 13582)) (13584 13696 (SETF-TYPE-EXPANDER 13584 . 13696)) (13918 15237 (ARRAY-TYPE 13918 .
|
||||
15237)) (15239 15457 (SYMBOL-TYPE 15239 . 15457)) (15459 15490 (XCL:FALSE 15459 . 15490)) (15492 15520
|
||||
(XCL:TRUE 15492 . 15520)) (15522 18961 (%RANGE-TYPE 15522 . 18961)) (18963 19020 (NUMBERP 18963 .
|
||||
19020)) (19022 19077 (FLOATP 19022 . 19077)) (19555 21413 (%TYPEP-PRED 19555 . 21413)) (21415 21504 (
|
||||
BIGNUMP 21415 . 21504)) (23517 31063 (SUBTYPEP 23517 . 31063)) (31065 31379 (SUBTYPEP-TYPE-EXPAND
|
||||
31065 . 31379)) (31381 31560 (SI::DATATYPE-P 31381 . 31560)) (31562 32330 (SI::SUB-DATATYPE-P 31562 .
|
||||
32330)) (32332 33015 (EQUAL-DIMENSIONS 32332 . 33015)) (33017 33216 (COMPLETE-ARRAY-TYPE-DIMENSIONS
|
||||
33017 . 33216)) (33218 34693 (COMPLETE-META-EXPRESSION-DEFAULTS 33218 . 34693)) (34695 36276 (RANGE<=
|
||||
34695 . 36276)) (36278 42968 (BASE-SUBTYPEP 36278 . 42968)) (42970 43336 (EQUAL-ELEMENT-TYPE 42970 .
|
||||
43336)) (43338 43672 (USEFUL-TYPE-EXPANSION-P 43338 . 43672)))))
|
||||
IL:STOP
|
||||
|
||||
Binary file not shown.
@@ -1,28 +1,35 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
|
||||
(FILECREATED "16-May-90 15:31:19" {DSK}<usr>local>lde>lispcore>sources>DEFPACKAGE-IMPORT.;2 1000
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
changes to%: (VARS DEFPACKAGE-IMPORTCOMS)
|
||||
(FILECREATED " 5-Sep-2024 22:33:36" {DSK}<home>matt>Interlisp>medley>sources>DEFPACKAGE-IMPORT.;2 1161
|
||||
|
||||
previous date%: "12-Dec-86 13:26:35" {DSK}<usr>local>lde>lispcore>sources>DEFPACKAGE-IMPORT.;1
|
||||
)
|
||||
:EDIT-BY "mth"
|
||||
|
||||
:CHANGES-TO (VARS DEFPACKAGE-IMPORTCOMS)
|
||||
|
||||
:PREVIOUS-DATE "16-May-90 15:31:19"
|
||||
{DSK}<home>matt>Interlisp>medley>sources>DEFPACKAGE-IMPORT.;1)
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1986, 1990 by Venue & Xerox Corporation. All rights reserved.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT DEFPACKAGE-IMPORTCOMS)
|
||||
|
||||
(RPAQQ DEFPACKAGE-IMPORTCOMS ((P (IMPORT (CL:INTERN "DEFPACKAGE" "XCL")
|
||||
"INTERLISP"))
|
||||
(PROP MAKEFILE-ENVIRONMENT DEFPACKAGE-IMPORT)))
|
||||
"INTERLISP")
|
||||
(IMPORT (CL:INTERN "DEFPACKAGE" "XCL")
|
||||
"LISP")
|
||||
(EXPORT (CL:FIND-SYMBOL "DEFPACKAGE" "LISP")
|
||||
"LISP"))
|
||||
(PROP MAKEFILE-ENVIRONMENT DEFPACKAGE-IMPORT)))
|
||||
|
||||
(IMPORT (CL:INTERN "DEFPACKAGE" "XCL")
|
||||
"INTERLISP")
|
||||
|
||||
(PUTPROPS DEFPACKAGE-IMPORT MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP"
|
||||
))
|
||||
(PUTPROPS DEFPACKAGE-IMPORT COPYRIGHT ("Venue & Xerox Corporation" 1986 1990))
|
||||
(IMPORT (CL:INTERN "DEFPACKAGE" "XCL")
|
||||
"LISP")
|
||||
|
||||
(EXPORT (CL:FIND-SYMBOL "DEFPACKAGE" "LISP")
|
||||
"LISP")
|
||||
|
||||
(PUTPROPS DEFPACKAGE-IMPORT MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP"))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL)))
|
||||
STOP
|
||||
|
||||
@@ -1 +1,17 @@
|
||||
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "25-Jan-98 12:25:04" ("compiled on " {DSK}<lispcore>sources>DEFPACKAGE-IMPORT.;1)
"30-Mar-95 20:33:04" bcompl'd in "Medley 14-Aug-95 ..." dated "14-Aug-95 15:27:48")
(FILECREATED "16-May-90 15:31:19" {DSK}<usr>local>lde>lispcore>sources>DEFPACKAGE-IMPORT.;2 1000
changes to%: (VARS DEFPACKAGE-IMPORTCOMS) previous date%: "12-Dec-86 13:26:35"
{DSK}<usr>local>lde>lispcore>sources>DEFPACKAGE-IMPORT.;1)
(PRETTYCOMPRINT DEFPACKAGE-IMPORTCOMS)
(RPAQQ DEFPACKAGE-IMPORTCOMS ((P (IMPORT (CL:INTERN "DEFPACKAGE" "XCL") "INTERLISP")) (PROP
MAKEFILE-ENVIRONMENT DEFPACKAGE-IMPORT)))
(IMPORT (CL:INTERN "DEFPACKAGE" "XCL") "INTERLISP")
(PUTPROPS DEFPACKAGE-IMPORT MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP"))
(PUTPROPS DEFPACKAGE-IMPORT COPYRIGHT ("Venue & Xerox Corporation" 1986 1990))
NIL
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 5-Sep-2024 22:35:06" ("compiled on "
|
||||
{DSK}<home>matt>Interlisp>medley>sources>DEFPACKAGE-IMPORT.;2) "31-Jul-2024 02:24:35" tcompl'd in
|
||||
"FULL 31-Jul-2024 ..." dated "31-Jul-2024 02:24:38")
|
||||
(FILECREATED " 5-Sep-2024 22:33:36" {DSK}<home>matt>Interlisp>medley>sources>DEFPACKAGE-IMPORT.;2 1161
|
||||
:EDIT-BY "mth" :CHANGES-TO (VARS DEFPACKAGE-IMPORTCOMS) :PREVIOUS-DATE "16-May-90 15:31:19"
|
||||
{DSK}<home>matt>Interlisp>medley>sources>DEFPACKAGE-IMPORT.;1)
|
||||
(PRETTYCOMPRINT DEFPACKAGE-IMPORTCOMS)
|
||||
(RPAQQ DEFPACKAGE-IMPORTCOMS ((P (IMPORT (CL:INTERN "DEFPACKAGE" "XCL") "INTERLISP") (IMPORT (CL:INTERN
|
||||
"DEFPACKAGE" "XCL") "LISP") (EXPORT (CL:FIND-SYMBOL "DEFPACKAGE" "LISP") "LISP")) (PROP
|
||||
MAKEFILE-ENVIRONMENT DEFPACKAGE-IMPORT)))
|
||||
(IMPORT (CL:INTERN "DEFPACKAGE" "XCL") "INTERLISP")
|
||||
(IMPORT (CL:INTERN "DEFPACKAGE" "XCL") "LISP")
|
||||
(EXPORT (CL:FIND-SYMBOL "DEFPACKAGE" "LISP") "LISP")
|
||||
(PUTPROPS DEFPACKAGE-IMPORT MAKEFILE-ENVIRONMENT (:READTABLE "INTERLISP" :PACKAGE "INTERLISP"))
|
||||
NIL
|
||||
|
||||
126
sources/INSPECT
126
sources/INSPECT
@@ -1,18 +1,14 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "14-Sep-2023 23:40:42" {WMEDLEY}<sources>INSPECT.;28 124779
|
||||
(FILECREATED " 4-Jul-2024 12:16:52" {WMEDLEY}<sources>INSPECT.;31 126551
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS INSPECTABLEFIELDNAMES)
|
||||
:CHANGES-TO (VARS INSPECTCOMS)
|
||||
|
||||
:PREVIOUS-DATE "15-Jun-2023 16:03:17" {WMEDLEY}<sources>INSPECT.;27)
|
||||
:PREVIOUS-DATE " 4-Jul-2024 11:11:46" {WMEDLEY}<sources>INSPECT.;30)
|
||||
|
||||
|
||||
(* ; "
|
||||
Copyright (c) 1982-1987, 1990-1991, 1993, 1995, 1999, 2018, 2021 by Venue & Xerox Corporation.
|
||||
")
|
||||
|
||||
(PRETTYCOMPRINT INSPECTCOMS)
|
||||
|
||||
(RPAQQ INSPECTCOMS
|
||||
@@ -71,6 +67,11 @@ Copyright (c) 1982-1987, 1990-1991, 1993, 1995, 1999, 2018, 2021 by Venue & Xero
|
||||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27
|
||||
28 29 30 31)
|
||||
GETTTBLPROP SETTTBLPROP]
|
||||
[COMS (* ;
|
||||
"Show USERDATA in the main inspect window")
|
||||
(FNS WINDOW\INSPECTPROPS WINDOW\PROPFETCHFN WINDOW\PROPSTOREFN)
|
||||
(ADDVARS (INSPECTMACROS (WINDOW WINDOW\INSPECTPROPS WINDOW\PROPFETCHFN
|
||||
WINDOW\PROPSTOREFN]
|
||||
(COMS (* ; "Hunk inspector")
|
||||
(FNS INSPECT/AS/BLOCKRECORD INSPECT/TYPELESS LIST-ALL-BLOCKRECORDS INSPECT/HUNK
|
||||
\INSPECT.DATATYPE.RAW.FETCH \INSPECT.FETCH.8 \INSPECT.FETCH.32 \INSPECT.FETCH.CHAR
|
||||
@@ -2054,6 +2055,41 @@ Copyright (c) 1982-1987, 1990-1991, 1993, 1995, 1999, 2018, 2021 by Venue & Xero
|
||||
|
||||
|
||||
|
||||
(* ; "Show USERDATA in the main inspect window")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(WINDOW\INSPECTPROPS
|
||||
[LAMBDA (WINDOW) (* ; "Edited 4-Jul-2024 00:03 by rmk")
|
||||
(* ; "Edited 30-Jun-2024 09:04 by rmk")
|
||||
|
||||
(* ;; "Stick the user properties at the end with --USERDATA-- separator. INSPECTABLEFIELDNAMES does the sort for defined field names, the UFIELDS have to be sorted here.")
|
||||
|
||||
(LET ([WFIELDS (REMOVE 'USERDATA (INSPECTABLEFIELDNAMES (SYSRECLOOK1 'WINDOW]
|
||||
(UFIELDS (for X in (fetch (WINDOW USERDATA) of WINDOW) by (CDDR X) collect X)))
|
||||
(CL:UNLESS (OR (EQ T INSPECTDONTSORTFIELDS)
|
||||
(MEMB 'WINDOW INSPECTDONTSORTFIELDS))
|
||||
(SETQ UFIELDS (SORT UFIELDS)))
|
||||
(APPEND WFIELDS (CONS '--USERDATA--)
|
||||
UFIELDS])
|
||||
|
||||
(WINDOW\PROPFETCHFN
|
||||
[LAMBDA (WINDOW PROPNAME) (* ; "Edited 3-Jul-2024 23:56 by rmk")
|
||||
(* ; "Edited 29-Jun-2024 22:57 by rmk")
|
||||
(if (EQ PROPNAME '--USERDATA--)
|
||||
then '------
|
||||
else (GETWINDOWPROP WINDOW PROPNAME])
|
||||
|
||||
(WINDOW\PROPSTOREFN
|
||||
[LAMBDA (WINDOW PROPNAME VALUE) (* ; "Edited 30-Jun-2024 08:52 by rmk")
|
||||
(CL:UNLESS (EQ PROPNAME '--USERDATA--)
|
||||
(PUTWINDOWPROP WINDOW PROPNAME VALUE])
|
||||
)
|
||||
|
||||
(ADDTOVAR INSPECTMACROS (WINDOW WINDOW\INSPECTPROPS WINDOW\PROPFETCHFN WINDOW\PROPSTOREFN))
|
||||
|
||||
|
||||
|
||||
(* ; "Hunk inspector")
|
||||
|
||||
(DEFINEQ
|
||||
@@ -2221,43 +2257,43 @@ Copyright (c) 1982-1987, 1990-1991, 1993, 1995, 1999, 2018, 2021 by Venue & Xero
|
||||
("As 32-bit array" '(32 \INSPECT.FETCH.32 \INSPECT.STORE.32))
|
||||
("As Character array" '(8 \INSPECT.FETCH.CHAR \INSPECT.STORE.CHAR))
|
||||
("As Fat Character array" '(16 \INSPECT.FETCH.FATCHAR \INSPECT.STORE.FATCHAR])
|
||||
(PUTPROPS INSPECT COPYRIGHT ("Venue & Xerox Corporation" 1982 1983 1984 1985 1986 1987 1990 1991 1993
|
||||
1995 1999 2018 2021))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (7001 45354 (INSPECTW.CREATE 7011 . 12306) (INSPECTW.REPAINTFN 12308 . 17844) (
|
||||
INSPECTW.REDISPLAY 17846 . 26718) (\INSPECTW.VALUE.MARGIN 26720 . 27123) (INSPECTW.REPLACE 27125 .
|
||||
27833) (INSPECTW.SELECTITEM 27835 . 28825) (\INSPECTW.REDISPLAYPROP 28827 . 31257) (INSPECTW.FETCH
|
||||
31259 . 31682) (INSPECTW.PROPERTIES 31684 . 32325) (DECODE.WINDOW.ARG 32327 . 34055) (
|
||||
DEFAULT.INSPECTW.PROPCOMMANDFN 34057 . 36085) (DEFAULT.INSPECTW.VALUECOMMANDFN 36087 . 37503) (
|
||||
DEFAULT.INSPECTW.TITLECOMMANDFN 37505 . 40954) (\SELITEM.FROM.PROPERTY 40956 . 41398) (
|
||||
\INSPECT.COMPUTE.TITLE 41400 . 42684) (LEVELEDFORM 42686 . 43405) (MAKEWITHINREGION 43407 . 45352)) (
|
||||
45355 62660 (ITEMW.REPAINTFN 45365 . 46585) (\ITEM.WINDOW.BUTTON.HANDLER 46587 . 47006) (
|
||||
\ITEM.WINDOW.SELECTION.HANDLER 47008 . 49675) (\INSPECTW.COMMAND.HANDLER 49677 . 53678) (
|
||||
ITEM.WINDOW.SET.STACK.ARG 53680 . 55884) (REPLACESTKARG 55886 . 56985) (IN/ITEM? 56987 . 57869) (
|
||||
\ITEMW.DESELECTITEM 57871 . 58135) (\ITEMW.SELECTITEM 58137 . 58399) (\ITEMW.CLEARSELECTION 58401 .
|
||||
58756) (\ITEMW.FLIPITEM 58758 . 59231) (PRINTANDBOX 59233 . 61742) (PRINTATBOX 61744 . 62261) (
|
||||
ITEMOFPROPERTYVALUE 62263 . 62658)) (62661 66402 (\ITEM.WINDOW.COPY.HANDLER 62671 . 64528) (
|
||||
\ITEMW.FLIPCOPY 64530 . 64989) (BKSYSBUF.GENERAL 64991 . 66400)) (66794 91709 (INSPECT 66804 . 71334)
|
||||
(\APPLYINSPECTMACRO 71336 . 72397) (INSPECT/BITMAP 72399 . 73551) (INSPECT/DATATYPE 73553 . 77067) (
|
||||
INSPECTABLEFIELDNAMES 77069 . 78402) (REMOVEDUPS 78404 . 78609) (INSPECT/ARRAY 78611 . 79676) (
|
||||
INSPECT/TOP/LEVEL/LIST 79678 . 80795) (INSPECT/PROPLIST 80797 . 81885) (NONSYSPROPNAMES 81887 . 82183)
|
||||
(INSPECT/LISTP 82185 . 82624) (ALISTP 82626 . 82835) (PROPLISTP 82837 . 83477) (INSPECT/ALIST 83479
|
||||
. 83955) (ASSOCGET 83957 . 84168) (/ASSOCPUT 84170 . 84435) (INSPECT/PLIST 84437 . 84921) (
|
||||
INSPECT/TYPERECORD 84923 . 85280) (INSPECT/AS/RECORD 85282 . 86519) (SELECT.LIST.INSPECTOR 86521 .
|
||||
88572) (STANDARDEDITE 88574 . 88857) (NTHTOPLEVELELT 88859 . 89175) (SETNTHTOPLEVELELT 89177 . 89937)
|
||||
(DEDITE 89939 . 90146) (FINDRECDECL 90148 . 90731) (FINDSYSRECDECL 90733 . 91134) (
|
||||
MAKE-INSPECTOR-PROFILE 91136 . 91521) (CONFIRM-SET 91523 . 91707)) (93533 101747 (INSPECT/ATOM 93543
|
||||
. 97648) (SELECT.ATOM.ASPECT 97650 . 98794) (INSPECT/AS/FUNCTION 98796 . 101082) (SELECT.FNS.EDITOR
|
||||
101084 . 101745)) (101788 107213 (INSPECTCODE 101798 . 102950) (\TEDIT.INSPECTCODE 102952 . 104930) (
|
||||
\INSPECT/CODE/RESHAPEFN 104932 . 106471) (\INSPECT/CODE/REPAINTFN 106473 . 107211)) (107251 108857 (
|
||||
INSPECT/HARRAYP 107261 . 108009) (HARRAYKEYS 108011 . 108390) (INSPECTW.GETHASH 108392 . 108619) (
|
||||
INSPECTW.PUTHASH 108621 . 108855)) (108906 115115 (RDTBL\NONOTHERCODES 108916 . 109936) (GETSYNTAXPROP
|
||||
109938 . 111436) (SETSYNTAXPROP 111438 . 113165) (GETTTBLPROP 113167 . 114085) (SETTTBLPROP 114087 .
|
||||
115113)) (115594 124236 (INSPECT/AS/BLOCKRECORD 115604 . 116604) (INSPECT/TYPELESS 116606 . 117997) (
|
||||
LIST-ALL-BLOCKRECORDS 117999 . 118274) (INSPECT/HUNK 118276 . 120879) (\INSPECT.DATATYPE.RAW.FETCH
|
||||
120881 . 121207) (\INSPECT.FETCH.8 121209 . 121358) (\INSPECT.FETCH.32 121360 . 121531) (
|
||||
\INSPECT.FETCH.CHAR 121533 . 121696) (\INSPECT.FETCH.FATCHAR 121698 . 121860) (\INSPECT.FETCH.PTR
|
||||
121862 . 122033) (\INSPECT.STORE.8 122035 . 122341) (\INSPECT.STORE.16 122343 . 122643) (
|
||||
\INSPECT.STORE.32 122645 . 123080) (\INSPECT.STORE.CHAR 123082 . 123408) (\INSPECT.STORE.FATCHAR
|
||||
123410 . 123732) (\INSPECT.STORE.PTR 123734 . 124081) (INSPECT/MAKE/CCODEP 124083 . 124234)))))
|
||||
(FILEMAP (NIL (7293 45646 (INSPECTW.CREATE 7303 . 12598) (INSPECTW.REPAINTFN 12600 . 18136) (
|
||||
INSPECTW.REDISPLAY 18138 . 27010) (\INSPECTW.VALUE.MARGIN 27012 . 27415) (INSPECTW.REPLACE 27417 .
|
||||
28125) (INSPECTW.SELECTITEM 28127 . 29117) (\INSPECTW.REDISPLAYPROP 29119 . 31549) (INSPECTW.FETCH
|
||||
31551 . 31974) (INSPECTW.PROPERTIES 31976 . 32617) (DECODE.WINDOW.ARG 32619 . 34347) (
|
||||
DEFAULT.INSPECTW.PROPCOMMANDFN 34349 . 36377) (DEFAULT.INSPECTW.VALUECOMMANDFN 36379 . 37795) (
|
||||
DEFAULT.INSPECTW.TITLECOMMANDFN 37797 . 41246) (\SELITEM.FROM.PROPERTY 41248 . 41690) (
|
||||
\INSPECT.COMPUTE.TITLE 41692 . 42976) (LEVELEDFORM 42978 . 43697) (MAKEWITHINREGION 43699 . 45644)) (
|
||||
45647 62952 (ITEMW.REPAINTFN 45657 . 46877) (\ITEM.WINDOW.BUTTON.HANDLER 46879 . 47298) (
|
||||
\ITEM.WINDOW.SELECTION.HANDLER 47300 . 49967) (\INSPECTW.COMMAND.HANDLER 49969 . 53970) (
|
||||
ITEM.WINDOW.SET.STACK.ARG 53972 . 56176) (REPLACESTKARG 56178 . 57277) (IN/ITEM? 57279 . 58161) (
|
||||
\ITEMW.DESELECTITEM 58163 . 58427) (\ITEMW.SELECTITEM 58429 . 58691) (\ITEMW.CLEARSELECTION 58693 .
|
||||
59048) (\ITEMW.FLIPITEM 59050 . 59523) (PRINTANDBOX 59525 . 62034) (PRINTATBOX 62036 . 62553) (
|
||||
ITEMOFPROPERTYVALUE 62555 . 62950)) (62953 66694 (\ITEM.WINDOW.COPY.HANDLER 62963 . 64820) (
|
||||
\ITEMW.FLIPCOPY 64822 . 65281) (BKSYSBUF.GENERAL 65283 . 66692)) (67086 92001 (INSPECT 67096 . 71626)
|
||||
(\APPLYINSPECTMACRO 71628 . 72689) (INSPECT/BITMAP 72691 . 73843) (INSPECT/DATATYPE 73845 . 77359) (
|
||||
INSPECTABLEFIELDNAMES 77361 . 78694) (REMOVEDUPS 78696 . 78901) (INSPECT/ARRAY 78903 . 79968) (
|
||||
INSPECT/TOP/LEVEL/LIST 79970 . 81087) (INSPECT/PROPLIST 81089 . 82177) (NONSYSPROPNAMES 82179 . 82475)
|
||||
(INSPECT/LISTP 82477 . 82916) (ALISTP 82918 . 83127) (PROPLISTP 83129 . 83769) (INSPECT/ALIST 83771
|
||||
. 84247) (ASSOCGET 84249 . 84460) (/ASSOCPUT 84462 . 84727) (INSPECT/PLIST 84729 . 85213) (
|
||||
INSPECT/TYPERECORD 85215 . 85572) (INSPECT/AS/RECORD 85574 . 86811) (SELECT.LIST.INSPECTOR 86813 .
|
||||
88864) (STANDARDEDITE 88866 . 89149) (NTHTOPLEVELELT 89151 . 89467) (SETNTHTOPLEVELELT 89469 . 90229)
|
||||
(DEDITE 90231 . 90438) (FINDRECDECL 90440 . 91023) (FINDSYSRECDECL 91025 . 91426) (
|
||||
MAKE-INSPECTOR-PROFILE 91428 . 91813) (CONFIRM-SET 91815 . 91999)) (93825 102039 (INSPECT/ATOM 93835
|
||||
. 97940) (SELECT.ATOM.ASPECT 97942 . 99086) (INSPECT/AS/FUNCTION 99088 . 101374) (SELECT.FNS.EDITOR
|
||||
101376 . 102037)) (102080 107505 (INSPECTCODE 102090 . 103242) (\TEDIT.INSPECTCODE 103244 . 105222) (
|
||||
\INSPECT/CODE/RESHAPEFN 105224 . 106763) (\INSPECT/CODE/REPAINTFN 106765 . 107503)) (107543 109149 (
|
||||
INSPECT/HARRAYP 107553 . 108301) (HARRAYKEYS 108303 . 108682) (INSPECTW.GETHASH 108684 . 108911) (
|
||||
INSPECTW.PUTHASH 108913 . 109147)) (109198 115407 (RDTBL\NONOTHERCODES 109208 . 110228) (GETSYNTAXPROP
|
||||
110230 . 111728) (SETSYNTAXPROP 111730 . 113457) (GETTTBLPROP 113459 . 114377) (SETTTBLPROP 114379 .
|
||||
115405)) (115912 117362 (WINDOW\INSPECTPROPS 115922 . 116777) (WINDOW\PROPFETCHFN 116779 . 117133) (
|
||||
WINDOW\PROPSTOREFN 117135 . 117360)) (117491 126133 (INSPECT/AS/BLOCKRECORD 117501 . 118501) (
|
||||
INSPECT/TYPELESS 118503 . 119894) (LIST-ALL-BLOCKRECORDS 119896 . 120171) (INSPECT/HUNK 120173 .
|
||||
122776) (\INSPECT.DATATYPE.RAW.FETCH 122778 . 123104) (\INSPECT.FETCH.8 123106 . 123255) (
|
||||
\INSPECT.FETCH.32 123257 . 123428) (\INSPECT.FETCH.CHAR 123430 . 123593) (\INSPECT.FETCH.FATCHAR
|
||||
123595 . 123757) (\INSPECT.FETCH.PTR 123759 . 123930) (\INSPECT.STORE.8 123932 . 124238) (
|
||||
\INSPECT.STORE.16 124240 . 124540) (\INSPECT.STORE.32 124542 . 124977) (\INSPECT.STORE.CHAR 124979 .
|
||||
125305) (\INSPECT.STORE.FATCHAR 125307 . 125629) (\INSPECT.STORE.PTR 125631 . 125978) (
|
||||
INSPECT/MAKE/CCODEP 125980 . 126131)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,15 +1,15 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "LISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
(IL:FILECREATED "24-Oct-2021 10:20:31" IL:|{DSK}<home>larry>medley>sources>LLPACKAGE.;4| 82444
|
||||
(IL:FILECREATED " 5-Sep-2024 17:42:20" IL:|{DSK}<home>matt>Interlisp>medley>sources>LLPACKAGE.;3| 87515
|
||||
|
||||
IL:|changes| IL:|to:| (IL:FUNCTIONS IL:FIND-EXTERNAL-SYMBOL IL:FIND-SYMBOL*)
|
||||
:EDIT-BY "mth"
|
||||
|
||||
IL:|previous| IL:|date:| "22-Sep-92 11:47:31" IL:|{DSK}<home>larry>medley>sources>LLPACKAGE.;1|
|
||||
:CHANGES-TO (IL:FNS XCL:DEFPACKAGE)
|
||||
|
||||
:PREVIOUS-DATE " 4-Sep-2024 13:17:23" IL:|{DSK}<home>matt>Interlisp>medley>sources>LLPACKAGE.;2|
|
||||
)
|
||||
|
||||
|
||||
; Copyright (c) 1986-1987, 1990-1992 by Venue & Xerox Corporation.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:LLPACKAGECOMS)
|
||||
|
||||
(IL:RPAQQ IL:LLPACKAGECOMS
|
||||
@@ -83,9 +83,9 @@
|
||||
|
||||
(IL:FUNCTIONS IL:\\INDEXATOMPNAME)
|
||||
(IL:* IL:\;
|
||||
"Defined in EXPORTS.ALL and used by the DO-SYMBOLS macro")
|
||||
"Defined in EXPORTS.ALL and used by the DO-SYMBOLS macro")
|
||||
(IL:DECLARE\: IL:EVAL@COMPILE (IL:* IL:\;
|
||||
"These are used in expanding the DO-SYMBOLS macro, which is used in this file.")
|
||||
"These are used in expanding the DO-SYMBOLS macro, which is used in this file.")
|
||||
(IL:FUNCTIONS IL:MAKE-DO-SYMBOLS-VARS IL:MAKE-DO-SYMBOLS-CODE))
|
||||
(IL:FUNCTIONS DO-EXTERNAL-SYMBOLS XCL:DO-LOCAL-SYMBOLS XCL:DO-INTERNAL-SYMBOLS DO-SYMBOLS
|
||||
DO-ALL-SYMBOLS)
|
||||
@@ -96,7 +96,7 @@
|
||||
(IL:FUNCTIONS IL:BRIEFLY-DESCRIBE-SYMBOL APROPOS APROPOS-LIST)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
"Reader and printer's interface to packages (plus *PACKAGE-FROM-INDEX* above)")
|
||||
"Reader and printer's interface to packages (plus *PACKAGE-FROM-INDEX* above)")
|
||||
|
||||
(IL:FUNCTIONS IL:FIND-EXTERNAL-SYMBOL)
|
||||
(IL:FUNCTIONS IL:FIND-EXACT-SYMBOL IL:PACKAGE-NAME-AS-SYMBOL IL:\\FIND.PACKAGE.INTERNAL)
|
||||
@@ -175,10 +175,10 @@
|
||||
)
|
||||
|
||||
(DEFMACRO IL:\\FATCHARSEENP (IL:BASE IL:OFFSET IL:LEN IL:FATP)
|
||||
`(AND ,IL:FATP (NOT (NULL (IL:FOR IL:I IL:FROM ,IL:OFFSET
|
||||
IL:TO (IL:SUB1 (IL:IPLUS ,IL:OFFSET ,IL:LEN))
|
||||
`(AND ,IL:FATP (NOT (NULL (IL:FOR IL:I IL:FROM ,IL:OFFSET IL:TO (IL:SUB1 (IL:IPLUS ,IL:OFFSET
|
||||
,IL:LEN))
|
||||
IL:SUCHTHAT (IL:IGREATERP (IL:\\GETBASEFAT ,IL:BASE IL:I)
|
||||
IL:\\MAXTHINCHAR))))))
|
||||
IL:\\MAXTHINCHAR))))))
|
||||
|
||||
(DEFMACRO IL:\\PACKAGIFY (IL:OBJ)
|
||||
"If OBJ isn't already a package, turn the symbol or string into the package of that name."
|
||||
@@ -220,9 +220,8 @@
|
||||
|
||||
(DEFUN IL:\\UPCASEBASE (IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
|
||||
(IL:|for| IL:I IL:|from| IL:OFFSET IL:|to| (IL:IPLUS IL:OFFSET IL:LENGTH)
|
||||
IL:|do| (IL:\\PUTBASECHAR IL:FATP IL:BASE IL:I (IL:NUMERIC-UPCASE (IL:\\GETBASECHAR
|
||||
IL:FATP IL:BASE IL:I
|
||||
)))))
|
||||
IL:|do| (IL:\\PUTBASECHAR IL:FATP IL:BASE IL:I (IL:NUMERIC-UPCASE (IL:\\GETBASECHAR IL:FATP
|
||||
IL:BASE IL:I)))))
|
||||
|
||||
(DEFUN IL:APROPOS-SEARCH (SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
|
||||
"The symbol to substring comparison macro for APROPOS and APROPOS-LIST. The string is assumed to already be uppercase."
|
||||
@@ -240,13 +239,13 @@
|
||||
T)
|
||||
(UNLESS (EQL (IL:\\GETBASECHAR IL:FATP IL:BASE IL:JNDEX)
|
||||
(IL:NUMERIC-UPCASE (IL:\\GETBASECHAR IL:SYMBOL-FATP IL:SYMBOL-BASE
|
||||
(IL:ADD1 IL:KNDEX))))
|
||||
(IL:ADD1 IL:KNDEX))))
|
||||
(RETURN NIL)))
|
||||
(RETURN T))))
|
||||
|
||||
(DEFSTRUCT (PACKAGE-HASHTABLE (:CONSTRUCTOR %MAKE-PACKAGE-HASHTABLE)
|
||||
(:COPIER NIL)
|
||||
(:PRINT-FUNCTION PRINT-PACKAGE-HASHTABLE))
|
||||
(:COPIER NIL)
|
||||
(:PRINT-FUNCTION PRINT-PACKAGE-HASHTABLE))
|
||||
"Packages are implemented using a special kind of hashtable (this one). It is an open hashtable with a parallel 8-bit I-vector of hash-codes. The primary purpose of the hash for each entry is to reduce paging by allowing collisions and misses to be detected without paging in the symbol and pname for an entry. If the hash for an entry doesn't match that for the symbol that we are looking for, then we can go on without touching the symbol, pname, or even hastable vector. It turns out that, contrary to my expectations, paging is a very important consideration the design of the package representation. Using a similar scheme without the entry hash, the fasloader was spending more than half its time paging in INTERN. The hash code also indicates the status of an entry. If it zero, the the entry is unused. If it is one, then it is deleted. Double-hashing is used for collision resolution."
|
||||
TABLE
|
||||
HASH
|
||||
@@ -255,9 +254,9 @@
|
||||
DELETED)
|
||||
|
||||
(DEFSTRUCT (PACKAGE (:CONC-NAME %PACKAGE-)
|
||||
(:CONSTRUCTOR %MAKE-PACKAGE)
|
||||
(:PREDICATE PACKAGEP)
|
||||
(:PRINT-FUNCTION PRINT-PACKAGE))
|
||||
(:CONSTRUCTOR %MAKE-PACKAGE)
|
||||
(:PREDICATE PACKAGEP)
|
||||
(:PRINT-FUNCTION PRINT-PACKAGE))
|
||||
INDEX
|
||||
(TABLES (LIST NIL))
|
||||
NAME NAMESYMBOL NICKNAMES (USE-LIST NIL)
|
||||
@@ -321,7 +320,7 @@
|
||||
"The current package, in which read symbols are intern'ed.")
|
||||
|
||||
(DEFVAR XCL::*UNSAFE-TO-DELETE-PACKAGE-NAMES* '("LISP" "INTERLISP" "XEROX-COMMON-LISP")
|
||||
"Packages whose deletion requires confirmation.")
|
||||
"Packages whose deletion requires confirmation.")
|
||||
|
||||
(XCL:DEFGLOBALVAR IL:*LISP-PACKAGE* NIL
|
||||
"Global for internal references to the lisp package.")
|
||||
@@ -357,8 +356,8 @@
|
||||
(IL:LEN (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| IL:PRINT-NAME))
|
||||
(IL:OFFST (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| IL:PRINT-NAME)))
|
||||
(IL:UNINTERRUPTABLY
|
||||
(IL:\\CREATE.SYMBOL IL:BASE IL:OFFST IL:LEN IL:FATP (IL:\\FATCHARSEENP IL:BASE
|
||||
IL:OFFST IL:LEN IL:FATP)))))
|
||||
(IL:\\CREATE.SYMBOL IL:BASE IL:OFFST IL:LEN IL:FATP (IL:\\FATCHARSEENP IL:BASE IL:OFFST
|
||||
IL:LEN IL:FATP)))))
|
||||
|
||||
|
||||
|
||||
@@ -367,12 +366,11 @@
|
||||
)
|
||||
|
||||
|
||||
(XCL:DEFGLOBALVAR IL:*PACKAGE-FROM-NAME* (IL:HASHARRAY 255 'IL:ERROR 'IL:STRINGHASHBITS
|
||||
'IL:STREQUAL)
|
||||
"An equal hashtable from package names to packages.")
|
||||
(XCL:DEFGLOBALVAR IL:*PACKAGE-FROM-NAME* (IL:HASHARRAY 255 'IL:ERROR 'IL:STRINGHASHBITS 'IL:STREQUAL)
|
||||
"An equal hashtable from package names to packages.")
|
||||
|
||||
(XCL:DEFGLOBALVAR IL:*PACKAGE-FROM-INDEX* (MAKE-ARRAY 256 ':INITIAL-ELEMENT NIL)
|
||||
"Index to package converter.")
|
||||
"Index to package converter.")
|
||||
|
||||
(DEFCONSTANT XCL:*TOTAL-PACKAGES-LIMIT* 255
|
||||
"The total number of packages that the system may have (excluding the 'uninterned' package).")
|
||||
@@ -499,9 +497,9 @@
|
||||
(RETURN IL:X)))))
|
||||
|
||||
(DEFUN MAKE-PACKAGE (NAME &KEY (USE '("LISP"))
|
||||
NICKNAMES PREFIX-NAME (EXTERNAL-ONLY NIL)
|
||||
(INTERNAL-SYMBOLS 10)
|
||||
(EXTERNAL-SYMBOLS 10))
|
||||
NICKNAMES PREFIX-NAME (EXTERNAL-ONLY NIL)
|
||||
(INTERNAL-SYMBOLS 10)
|
||||
(EXTERNAL-SYMBOLS 10))
|
||||
"Check for package name conflicts in name and nicknames, then make the package. Do a use-package for each thing in the use list so that checking for conflicting exports among used packages is done."
|
||||
(DECLARE (SPECIAL IL:*PACKAGE-FROM-INDEX* IL:*PACKAGE-FROM-NAME*))
|
||||
(WHEN (FIND-PACKAGE NAME)
|
||||
@@ -518,14 +516,143 @@
|
||||
:INDEX %PACKAGE-INDEX)))
|
||||
(USE-PACKAGE USE PACKAGE)
|
||||
(IL:ENTER-NEW-NICKNAMES PACKAGE (IF (IL:STREQUAL NAME (SYMBOL-NAME PREFIX-NAME))
|
||||
NICKNAMES
|
||||
(CONS PREFIX-NAME NICKNAMES)))
|
||||
NICKNAMES
|
||||
(CONS PREFIX-NAME NICKNAMES)))
|
||||
(IL:PUTHASH NAME PACKAGE IL:*PACKAGE-FROM-NAME*)
|
||||
(SETF (AREF IL:*PACKAGE-FROM-INDEX* %PACKAGE-INDEX)
|
||||
PACKAGE)))
|
||||
(IL:DEFINEQ
|
||||
|
||||
(xcl:defpackage
|
||||
(XCL:DEFPACKAGE
|
||||
(IL:NLAMBDA IL:ARGS (IL:* IL:\; "Edited 4-Sep-2024 13:17 by mth")
|
||||
(IL:* IL:\; "Edited 2-Dec-87 10:39 by raf")
|
||||
(IL:SETQ IL:ARGS (XCL:REMOVE-COMMENTS IL:ARGS))
|
||||
(LET
|
||||
((PACKAGE (FIND-PACKAGE (CAR IL:ARGS))))
|
||||
(COND
|
||||
((PACKAGEP PACKAGE) (IL:* IL:\;
|
||||
"If one already exists, test compatability of package definitions")
|
||||
(IL:|for| IL:OPTION IL:|in| (CDR IL:ARGS)
|
||||
IL:|do|
|
||||
(LET* ((IL:KEY (COND
|
||||
((KEYWORDP IL:OPTION)
|
||||
IL:OPTION)
|
||||
((IL:LISTP IL:OPTION)
|
||||
(CAR IL:OPTION))
|
||||
(T (IL:ERROR "Bad option for defpackage " IL:OPTION))))
|
||||
(VALUES (COND
|
||||
((KEYWORDP IL:OPTION)
|
||||
(LIST T))
|
||||
((IL:LISTP IL:OPTION)
|
||||
(CDR IL:OPTION))
|
||||
(T (IL:ERROR "Bad option for defpackage " IL:OPTION)))))
|
||||
(IL:SELECTQ IL:KEY
|
||||
((:INTERNAL-SYMBOLS :EXTERNAL-SYMBOLS)
|
||||
NIL)
|
||||
(:EXTERNAL-ONLY (IF (NOT (%PACKAGE-EXTERNAL-ONLY PACKAGE))
|
||||
(IL:ERROR
|
||||
"Package NOT :external-only as asserted by defpackage: "
|
||||
PACKAGE)))
|
||||
(:PREFIX-NAME (SETF (%PACKAGE-NAMESYMBOL PACKAGE)
|
||||
(MAKE-SYMBOL (CAR VALUES))))
|
||||
(:USE (USE-PACKAGE VALUES PACKAGE))
|
||||
(:NICKNAMES (IL:ENTER-NEW-NICKNAMES PACKAGE VALUES))
|
||||
(:EXPORT (EXPORT (IL:FOR IL:SYMBOL IL:IN VALUES
|
||||
IL:COLLECT (IL:IF (IL:LITATOM IL:SYMBOL)
|
||||
IL:THEN (IL:IF (SYMBOL-PACKAGE IL:SYMBOL)
|
||||
IL:THEN IL:SYMBOL
|
||||
IL:ELSE (INTERN (SYMBOL-NAME
|
||||
IL:SYMBOL)
|
||||
PACKAGE))
|
||||
IL:ELSEIF (IL:STRINGP IL:SYMBOL)
|
||||
IL:THEN (INTERN IL:SYMBOL PACKAGE)
|
||||
IL:ELSE (IL:ERROR
|
||||
"Bad object in :export option of defpackage "
|
||||
IL:SYMBOL)))
|
||||
PACKAGE))
|
||||
(:IMPORT (IMPORT VALUES PACKAGE))
|
||||
((:SHADOW :SHADOWING-IMPORT)
|
||||
(LET ((IL:SYMBOLS-TO-SHADOW (IL:MAPCONC
|
||||
VALUES
|
||||
(IL:FUNCTION (IL:LAMBDA (SYMBOL)
|
||||
(COND
|
||||
((NOT
|
||||
(IL:MEMB SYMBOL
|
||||
(
|
||||
%PACKAGE-SHADOWING-SYMBOLS
|
||||
PACKAGE)))
|
||||
(LIST SYMBOL))))))))
|
||||
(IL:SELECTQ IL:KEY
|
||||
(:SHADOW (SHADOW IL:SYMBOLS-TO-SHADOW PACKAGE))
|
||||
(:SHADOWING-IMPORT
|
||||
(SHADOWING-IMPORT IL:SYMBOLS-TO-SHADOW PACKAGE))
|
||||
NIL)))
|
||||
(IL:ERROR "Bad keyword for defpackage " IL:KEY)))))
|
||||
(T (IL:* IL:\;
|
||||
"Otherwise, make a new package to spec")
|
||||
(LET
|
||||
((IL:POST-MAKE-FORMS NIL))
|
||||
(IL:SETQ PACKAGE
|
||||
(IL:APPLY 'MAKE-PACKAGE
|
||||
(CONS (CAR IL:ARGS)
|
||||
(IL:|for| IL:OPTION IL:|in| (CDR IL:ARGS)
|
||||
IL:|join| (LET ((IL:KEY (COND
|
||||
((KEYWORDP IL:OPTION)
|
||||
IL:OPTION)
|
||||
((IL:LISTP IL:OPTION)
|
||||
(CAR IL:OPTION))
|
||||
(T (IL:ERROR "Bad option for defpackage "
|
||||
IL:OPTION))))
|
||||
(VALUES (COND
|
||||
((KEYWORDP IL:OPTION)
|
||||
(LIST T))
|
||||
((IL:LISTP IL:OPTION)
|
||||
(CDR IL:OPTION))
|
||||
(T (IL:ERROR "Bad option for defpackage "
|
||||
IL:OPTION)))))
|
||||
(IL:SELECTQ IL:KEY
|
||||
((:USE :NICKNAMES)
|
||||
(LIST IL:KEY (IL:|if| (CAR VALUES)
|
||||
IL:|then| VALUES
|
||||
IL:|else|
|
||||
(IL:* IL:\; "Handles case where NIL is being used to explicitly say the package's :USE list is empty, since the default is to use LISP.")
|
||||
NIL)))
|
||||
((:PREFIX-NAME :INTERNAL-SYMBOLS :EXTERNAL-SYMBOLS
|
||||
:EXTERNAL-ONLY)
|
||||
(LIST IL:KEY (CAR VALUES)))
|
||||
((:SHADOW :EXPORT :IMPORT :SHADOWING-IMPORT)
|
||||
(IL:SETQ IL:POST-MAKE-FORMS
|
||||
(CONS (CONS IL:KEY VALUES)
|
||||
IL:POST-MAKE-FORMS))
|
||||
NIL)
|
||||
(IL:ERROR "Bad keyword for defpackage " IL:KEY)))))))
|
||||
(IL:MAPC
|
||||
IL:POST-MAKE-FORMS
|
||||
(IL:FUNCTION (IL:LAMBDA (IL:FORM)
|
||||
(IL:SELECTQ (CAR IL:FORM)
|
||||
(:SHADOW (SHADOW (CDR IL:FORM)
|
||||
PACKAGE))
|
||||
(:EXPORT (EXPORT
|
||||
(IL:FOR IL:SYMBOL IL:IN (CDR IL:FORM)
|
||||
IL:COLLECT (IL:IF (IL:LITATOM IL:SYMBOL)
|
||||
IL:THEN (IL:IF (SYMBOL-PACKAGE IL:SYMBOL)
|
||||
IL:THEN IL:SYMBOL
|
||||
IL:ELSE (INTERN (SYMBOL-NAME
|
||||
IL:SYMBOL)
|
||||
PACKAGE))
|
||||
IL:ELSEIF (IL:STRINGP IL:SYMBOL)
|
||||
IL:THEN (INTERN IL:SYMBOL PACKAGE)
|
||||
IL:ELSE (IL:ERROR
|
||||
"Bad object in :export option of defpackage "
|
||||
IL:SYMBOL)))
|
||||
PACKAGE))
|
||||
(:IMPORT (IMPORT (CDR IL:FORM)
|
||||
PACKAGE))
|
||||
(:SHADOWING-IMPORT
|
||||
(SHADOWING-IMPORT (CDR IL:FORM)
|
||||
PACKAGE))
|
||||
(IL:SHOULDNT "Bogus form on post-make-forms"))))))))
|
||||
(PACKAGE-NAME PACKAGE))))
|
||||
)
|
||||
|
||||
|
||||
@@ -569,16 +696,15 @@
|
||||
(NOT (IL:FMEMB IL:SYM IL:SHADOWING-SYMBOLS)))
|
||||
(PUSHNEW IL:SYM IL:CSET :TEST 'EQ))))
|
||||
(DOLIST (IL:P IL:USE-LIST)
|
||||
(PUSHNEW IL:SYM IL:CSET :TEST 'EQ))))
|
||||
(DOLIST (IL:P IL:USE-LIST)
|
||||
(DO-EXTERNAL-SYMBOLS
|
||||
(IL:SYM IL:P)
|
||||
(MULTIPLE-VALUE-BIND (IL:S IL:W)
|
||||
(IL:FIND-EXTERNAL-SYMBOL (SYMBOL-NAME IL:SYM)
|
||||
IL:PKG)
|
||||
(WHEN (AND IL:W (NOT (EQ IL:S IL:SYM))
|
||||
(NOT (IL:FMEMB (INTERN (SYMBOL-NAME IL:SYM)
|
||||
PACKAGE)
|
||||
(DO-EXTERNAL-SYMBOLS (IL:SYM IL:P)
|
||||
(MULTIPLE-VALUE-BIND (IL:S IL:W)
|
||||
(IL:FIND-EXTERNAL-SYMBOL (SYMBOL-NAME IL:SYM)
|
||||
IL:PKG)
|
||||
(WHEN (AND IL:W (NOT (EQ IL:S IL:SYM))
|
||||
(NOT (IL:FMEMB (INTERN (SYMBOL-NAME IL:SYM)
|
||||
PACKAGE)
|
||||
IL:SHADOWING-SYMBOLS)))
|
||||
(PUSHNEW IL:SYM IL:CSET :TEST 'EQ))))))
|
||||
(T (DO-EXTERNAL-SYMBOLS (IL:SYM IL:PKG)
|
||||
(MULTIPLE-VALUE-BIND (IL:S IL:W)
|
||||
(FIND-SYMBOL (SYMBOL-NAME IL:SYM)
|
||||
@@ -800,7 +926,7 @@
|
||||
(UNLESS (AND IL:W (EQ IL:S IL:SYM))
|
||||
(WHEN (OR (EQ IL:W :INTERNAL)
|
||||
(EQ IL:W :EXTERNAL)) (IL:* IL:\;
|
||||
(WHEN (OR (EQ IL:W :INTERNAL)
|
||||
" If it was shadowed, we don't want Unintern to fail")
|
||||
(SETF (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)
|
||||
(DELETE IL:S (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)))
|
||||
(UNINTERN IL:S PACKAGE))
|
||||
@@ -873,7 +999,7 @@
|
||||
(SXHASH (IL:SYMBOL-HASH IL:SYMBOL-BASE 1 IL:SYMBOL-LENGTH IL:SYMBOL-FATP))
|
||||
(IL:H2 (IL:REHASH-FACTOR SXHASH IL:LEN)))
|
||||
(DECLARE (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 32))
|
||||
(IL:H2 (IL:REHASH-FACTOR SXHASH IL:LEN)))
|
||||
IL:VEC)
|
||||
(TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8))
|
||||
IL:HASH))
|
||||
(COND
|
||||
@@ -886,7 +1012,7 @@
|
||||
((>= IL:SIZE IL:HASHTABLE-SIZE-LIMIT)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
|
||||
"We've spilled over into needing the list-of-tables feature, so add to the list.")
|
||||
|
||||
(IL:SETQ IL:VEC (IL:NCONC1 IL:VEC (MAKE-ARRAY IL:LEN :ELEMENT-TYPE
|
||||
'(UNSIGNED-BYTE 32))))
|
||||
@@ -898,7 +1024,7 @@
|
||||
(IL:ADD-SYMBOL IL:TABLE SYMBOL))
|
||||
(T
|
||||
(IL:* IL:|;;|
|
||||
(T
|
||||
"The initial table is still smaller than the limit. Increase its size.")
|
||||
|
||||
(LET ((IL:SIZE (PACKAGE-HASHTABLE-SIZE IL:TABLE))
|
||||
(IL:VEC1 (CAR IL:VEC))
|
||||
@@ -909,8 +1035,7 @@
|
||||
(DOTIMES (IL:I IL:LEN)
|
||||
(WHEN (IL:IGREATERP (AREF IL:HASH1 IL:I)
|
||||
1)
|
||||
(WHEN (IL:IGREATERP (AREF IL:HASH1 IL:I)
|
||||
1)
|
||||
(IL:ADD-SYMBOL IL:TABLE (IL:\\INDEXATOMPNAME (AREF IL:VEC1 IL:I))))))
|
||||
)))
|
||||
(T (LET ((IL:THIS-HASH (CAR (IL:FLAST IL:HASH)))
|
||||
(IL:THIS-VEC (CAR (IL:FLAST IL:VEC))))
|
||||
@@ -926,10 +1051,9 @@
|
||||
(SETF (AREF IL:THIS-HASH IL:I)
|
||||
(IL:ENTRY-HASH IL:SYMBOL-LENGTH SXHASH)))))))))
|
||||
|
||||
(IL:ENTRY-HASH IL:SYMBOL-LENGTH SXHASH)))))))))
|
||||
|
||||
(DEFMACRO IL:WITH-SYMBOL ((IL:INDEX-VAR IL:SYMBOL-VAR IL:TABLE IL:BASE IL:OFFSET IL:LENGTH
|
||||
IL:FATP SXHASH IL:ENTRY-HASH IL:HASH-TABLE-TABLE
|
||||
(DEFMACRO IL:WITH-SYMBOL ((IL:INDEX-VAR IL:SYMBOL-VAR IL:TABLE IL:BASE IL:OFFSET IL:LENGTH IL:FATP
|
||||
SXHASH IL:ENTRY-HASH IL:HASH-TABLE-TABLE IL:HASH-TABLE-HASH)
|
||||
&BODY IL:FORMS)
|
||||
"Find where the symbol named String is stored in Table. Index-Var is bound to the index, or NIL if it is not present. Symbol-Var is bound to the symbol. Length and Hash are the length and sxhash of String. Entry-Hash is the entry-hash of the string and length."
|
||||
(LET ((IL:VEC (OR IL:HASH-TABLE-TABLE (IL:GENSYM)))
|
||||
(IL:HASH (OR IL:HASH-TABLE-HASH (IL:GENSYM)))
|
||||
@@ -947,7 +1071,7 @@
|
||||
,IL:HASH
|
||||
,IL:LIMIT)
|
||||
(DECLARE (TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 8))
|
||||
,IL:LIMIT)
|
||||
,IL:HASH)
|
||||
(TYPE (SIMPLE-ARRAY (UNSIGNED-BYTE 32))
|
||||
,IL:VEC))
|
||||
(PROG (,IL:INDEX-VAR ,IL:SYMBOL-VAR ,IL:EHASH)
|
||||
@@ -955,9 +1079,8 @@
|
||||
(IL:* IL:|;;| "Loop thru all the hash tables looking for the symbol.")
|
||||
|
||||
IL:OUTER-LOOP
|
||||
|
||||
IL:OUTER-LOOP
|
||||
(IL:SETQ ,IL:HASH (IL:POP ,IL:HASHS))
|
||||
(IL:SETQ ,IL:HASH (IL:POP ,IL:HASHS)) (IL:* IL:\; "Hashvalues")
|
||||
(IL:SETQ ,IL:VEC (IL:POP ,IL:VECS)) (IL:* IL:\; "The symbol vector")
|
||||
(IL:SETQ ,IL:INDEX-VAR (IL:IREMAINDER ,SXHASH ,IL:LEN))
|
||||
(IL:* IL:\; "Starting probe.")
|
||||
(IL:SETQ ,IL:LIMIT ,IL:LEN)
|
||||
@@ -972,37 +1095,34 @@
|
||||
|
||||
(IL:* IL:|;;| "SIngle-byte hash matches; try the whole name.")
|
||||
|
||||
(IL:* IL:|;;| "SIngle-byte hash matches; try the whole name.")
|
||||
|
||||
(IL:SETQ ,IL:SYMBOL-VAR (IL:\\INDEXATOMPNAME (AREF ,IL:VEC
|
||||
,IL:INDEX-VAR)))
|
||||
(IL:SETQ ,IL:SYMBOL-VAR (IL:\\INDEXATOMPNAME (AREF ,IL:VEC ,IL:INDEX-VAR)))
|
||||
(WHEN (IL:\\SYMBOL-EQUALBASE ,IL:SYMBOL-VAR ,IL:BASE ,IL:OFFSET ,IL:LENGTH
|
||||
,IL:FATP)
|
||||
(GO IL:DOIT)))
|
||||
((EQL 0 ,IL:EHASH) (IL:* IL:\;
|
||||
(GO IL:DOIT)))
|
||||
"Found an empty hash slot, so it's not in this table.")
|
||||
(COND
|
||||
((NULL ,IL:HASHS)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
|
||||
"we've run out of sub-tables to look in. Give the we-couldn't-find-it signal.")
|
||||
|
||||
(IL:SETQ ,IL:INDEX-VAR NIL)
|
||||
(GO IL:DOIT))
|
||||
(T (GO IL:OUTER-LOOP))))
|
||||
((EQL 0 (IL:SETQ ,IL:LIMIT (IL:SUB1 ,IL:LIMIT)))
|
||||
(IL:* IL:\;
|
||||
((EQL 0 (IL:SETQ ,IL:LIMIT (IL:SUB1 ,IL:LIMIT)))
|
||||
"We.ve been thru the whole table, so it's not in this table.")
|
||||
(COND
|
||||
((NULL ,IL:HASHS)
|
||||
|
||||
(IL:* IL:|;;|
|
||||
|
||||
"we've run out of sub-tables to look in. Give the we-couldn't-find-it signal.")
|
||||
|
||||
(IL:SETQ ,IL:INDEX-VAR NIL)
|
||||
(GO IL:DOIT))
|
||||
(T (GO IL:OUTER-LOOP)))))
|
||||
(GO IL:DOIT))
|
||||
(T (GO IL:OUTER-LOOP)))))
|
||||
(IL:SETQ ,IL:INDEX-VAR (IL:SYMBOL-HASH-REPROBE ,IL:INDEX-VAR ,IL:H2 ,IL:LEN))
|
||||
(GO LOOP)
|
||||
IL:DOIT
|
||||
(RETURN (PROGN ,@IL:FORMS))))))
|
||||
@@ -1051,12 +1171,12 @@
|
||||
(IL:SETQ IL:WHERE :INTERNAL)
|
||||
(IL:SETQ IL:DONE T))))
|
||||
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)
|
||||
(IL:SETQ IL:DONE T))))
|
||||
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-INTERNAL-SYMBOLS PACKAGE)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL
|
||||
NIL)
|
||||
(WHEN IL:FOUND
|
||||
|
||||
(IL:* IL:|;;|
|
||||
|
||||
"Was (cl:return-from find-symbol* (cl:values cl:symbol :internal))")
|
||||
|
||||
(IL:SETQ IL:WHERE :INTERNAL)
|
||||
(IL:SETQ IL:DONE T)))))
|
||||
@@ -1071,12 +1191,12 @@
|
||||
(IL:SETQ IL:WHERE :EXTERNAL)
|
||||
(IL:SETQ IL:DONE T))))
|
||||
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
|
||||
(IL:SETQ IL:DONE T))))
|
||||
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL
|
||||
NIL)
|
||||
(WHEN IL:FOUND
|
||||
|
||||
(IL:* IL:|;;|
|
||||
|
||||
"Was (cl:return-from find-symbol* (cl:values cl:symbol :external))")
|
||||
|
||||
(IL:SETQ IL:SYM SYMBOL)
|
||||
(IL:SETQ IL:WHERE :EXTERNAL)
|
||||
@@ -1101,13 +1221,13 @@
|
||||
IL:TABLE))
|
||||
|
||||
(IL:* IL:|;;|
|
||||
|
||||
"Was (cl:return-from find-symbol* (cl:values cl:symbol :inherited))")
|
||||
|
||||
(IL:SETQ IL:WHERE :INHERITED)
|
||||
(IL:SETQ IL:DONE T))))
|
||||
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (CAR IL:TABLE)
|
||||
(IL:SETQ IL:DONE T))))
|
||||
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (CAR IL:TABLE)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH
|
||||
IL:EHASH NIL NIL)
|
||||
(WHEN IL:FOUND
|
||||
(UNLESS (EQ IL:PREV IL:HEAD)
|
||||
(SHIFTF (CDR IL:PREV)
|
||||
@@ -1116,7 +1236,7 @@
|
||||
IL:TABLE))
|
||||
|
||||
(IL:* IL:|;;|
|
||||
|
||||
"Was (cl:return-from find-symbol* (cl:values cl:symbol :inherited))")
|
||||
|
||||
(IL:SETQ IL:SYM SYMBOL)
|
||||
(IL:SETQ IL:WHERE :INHERITED)
|
||||
@@ -1134,17 +1254,17 @@
|
||||
(T (IL:ERROR "Not a string " IL:NAME))))
|
||||
(COND
|
||||
((NULL PACKAGE) (IL:* IL:\;
|
||||
(COND
|
||||
"XCL extension, makes uninterned symbols")
|
||||
(MAKE-SYMBOL IL:NAME))
|
||||
(T (IL:* IL:\;
|
||||
(MAKE-SYMBOL IL:NAME))
|
||||
"Package is at least non-null")
|
||||
(IL:SETQ PACKAGE (IL:\\PACKAGIFY PACKAGE))
|
||||
(LET ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| IL:NAME))
|
||||
(IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| IL:NAME))
|
||||
(IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| IL:NAME))
|
||||
(IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| IL:NAME)))
|
||||
(IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| IL:NAME))
|
||||
(IL:FATP (IL:|ffetch| (IL:STRINGP IL:FATSTRINGP) IL:|of| IL:NAME)))
|
||||
(IL:INTERN* IL:BASE IL:OFFSET IL:LENGTH IL:FATP (IL:\\FATCHARSEENP IL:BASE IL:OFFSET
|
||||
IL:LENGTH IL:FATP)
|
||||
PACKAGE NIL)))))
|
||||
|
||||
(DEFUN FIND-SYMBOL (IL:NAME &OPTIONAL (PACKAGE *PACKAGE*))
|
||||
@@ -1173,7 +1293,7 @@
|
||||
(IL:HASH (IL:SYMBOL-HASH IL:BASE IL:OFFSET IL:LENGTH IL:FATP))
|
||||
(IL:EHASH (IL:ENTRY-HASH IL:LENGTH IL:HASH)))
|
||||
(IL:WITH-SYMBOL (IL:INDEX SYMBOL IL:TABLE IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH
|
||||
(IL:EHASH (IL:ENTRY-HASH IL:LENGTH IL:HASH)))
|
||||
IL:EHASH NIL IL:TABLE-HASH)
|
||||
(SETF (AREF IL:TABLE-HASH IL:INDEX)
|
||||
1)
|
||||
(INCF (PACKAGE-HASHTABLE-DELETED IL:TABLE)))))
|
||||
@@ -1196,7 +1316,7 @@
|
||||
(IL:FIND-EXTERNAL-SYMBOL IL:NAME IL:P)
|
||||
(WHEN IL:W (PUSHNEW IL:S IL:CSET))))
|
||||
(WHEN (CDR IL:CSET) (IL:* IL:\;
|
||||
(WHEN IL:W (PUSHNEW IL:S IL:CSET))))
|
||||
"If there is more than one, handle the conflict")
|
||||
(IL:RESOLVE-UNINTERN-CONFLICT SYMBOL IL:CSET PACKAGE)))
|
||||
(SETF (%PACKAGE-SHADOWING-SYMBOLS PACKAGE)
|
||||
(DELETE SYMBOL IL:SHADOWING-SYMBOLS :TEST #'EQ)))
|
||||
@@ -1207,8 +1327,8 @@
|
||||
(OR (EQ IL:W :INTERNAL)
|
||||
(EQ IL:W :EXTERNAL)))
|
||||
(IL:NUKE-SYMBOL (IF (EQ IL:W :INTERNAL)
|
||||
(EQ IL:W :EXTERNAL)))
|
||||
(IL:NUKE-SYMBOL (IF (EQ IL:W :INTERNAL)
|
||||
(%PACKAGE-INTERNAL-SYMBOLS PACKAGE)
|
||||
(%PACKAGE-EXTERNAL-SYMBOLS PACKAGE))
|
||||
IL:NAME)
|
||||
(IF (EQ (SYMBOL-PACKAGE SYMBOL)
|
||||
PACKAGE)
|
||||
@@ -1291,9 +1411,9 @@
|
||||
)
|
||||
|
||||
(DEFMACRO DO-EXTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
|
||||
|
||||
(DEFMACRO DO-EXTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
|
||||
IL:RESULT-FORM)
|
||||
IL:RESULT-FORM)
|
||||
&BODY
|
||||
(IL:CODE IL:DECLS))
|
||||
"Do-External-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms once for each external symbol in the given Package with Var bound to the current symbol."
|
||||
(LET ((IL:VARS (IL:MAKE-DO-SYMBOLS-VARS)))
|
||||
`(PROG (,IL:VAR ,@IL:VARS)
|
||||
@@ -1304,9 +1424,9 @@
|
||||
IL:CODE))))
|
||||
|
||||
(DEFMACRO XCL:DO-LOCAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
|
||||
|
||||
(DEFMACRO XCL:DO-LOCAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
|
||||
IL:RESULT-FORM)
|
||||
IL:RESULT-FORM)
|
||||
&BODY
|
||||
(IL:CODE IL:DECLS))
|
||||
"Do-Local-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms at least once for each symbol actually in the given Package with Var bound to the current symbol."
|
||||
(LET* ((IL:DONE-INTERNAL (IL:GENSYM))
|
||||
(IL:DONE-EXTERNAL (IL:GENSYM))
|
||||
@@ -1318,13 +1438,11 @@
|
||||
,@IL:DECLS
|
||||
(WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE)
|
||||
(GO ,IL:DONE-INTERNAL))
|
||||
(WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE)
|
||||
(GO ,IL:DONE-INTERNAL))
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS ,PACKAGE)
|
||||
`(GO ,IL:DONE-INTERNAL)
|
||||
IL:CODE)
|
||||
,IL:DONE-INTERNAL
|
||||
IL:CODE)
|
||||
,IL:DONE-INTERNAL
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS ,PACKAGE)
|
||||
`(GO ,IL:DONE-EXTERNAL)
|
||||
IL:CODE)
|
||||
,IL:DONE-EXTERNAL
|
||||
@@ -1332,9 +1450,9 @@
|
||||
(RETURN ,IL:RESULT-FORM))))
|
||||
|
||||
(DEFMACRO XCL:DO-INTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
|
||||
|
||||
(DEFMACRO XCL:DO-INTERNAL-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
|
||||
IL:RESULT-FORM)
|
||||
IL:RESULT-FORM)
|
||||
&BODY
|
||||
(IL:CODE IL:DECLS))
|
||||
"Do-Internal-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms at least once for each symbol actually in the given Package and not exported with Var bound to the current symbol."
|
||||
(LET* ((IL:DONE-INTERNAL (IL:GENSYM))
|
||||
(IL:VARS (IL:MAKE-DO-SYMBOLS-VARS))
|
||||
@@ -1345,8 +1463,7 @@
|
||||
,@IL:DECLS
|
||||
(WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE)
|
||||
(GO ,IL:DONE-INTERNAL))
|
||||
(WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE)
|
||||
(GO ,IL:DONE-INTERNAL))
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS ,PACKAGE)
|
||||
`(GO ,IL:DONE-INTERNAL)
|
||||
IL:CODE)
|
||||
,IL:DONE-INTERNAL
|
||||
@@ -1354,9 +1471,9 @@
|
||||
(RETURN ,IL:RESULT-FORM))))
|
||||
|
||||
(DEFMACRO DO-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
|
||||
|
||||
(DEFMACRO DO-SYMBOLS ((IL:VAR &OPTIONAL (PACKAGE '*PACKAGE*)
|
||||
IL:RESULT-FORM)
|
||||
IL:RESULT-FORM)
|
||||
&BODY
|
||||
(IL:CODE IL:DECLS))
|
||||
"Do-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms at least once for each symbol accessible in the given Package with Var bound to the current symbol."
|
||||
(LET* ((IL:DONE-INTERNAL (IL:GENSYM))
|
||||
(IL:DONE-EXTERNAL (IL:GENSYM))
|
||||
@@ -1375,13 +1492,11 @@
|
||||
,@IL:DECLS
|
||||
(WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE)
|
||||
(GO ,IL:DONE-INTERNAL))
|
||||
(WHEN (%PACKAGE-EXTERNAL-ONLY ,PACKAGE)
|
||||
(GO ,IL:DONE-INTERNAL))
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS ,PACKAGE)
|
||||
`(GO ,IL:DONE-INTERNAL)
|
||||
IL:CODE)
|
||||
,IL:DONE-INTERNAL
|
||||
IL:CODE)
|
||||
,IL:DONE-INTERNAL
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS ,PACKAGE)
|
||||
`(GO ,IL:DONE-EXTERNAL)
|
||||
IL:CODE)
|
||||
,IL:DONE-EXTERNAL
|
||||
@@ -1390,29 +1505,29 @@
|
||||
(IL:SETQ ,IL:VAR NIL)
|
||||
(RETURN ,IL:RESULT-FORM))
|
||||
(IL:SETQ ,IL:THIS-INHERIT (CAR ,IL:INHERITS))
|
||||
(RETURN ,IL:RESULT-FORM))
|
||||
(IL:SETQ ,IL:THIS-INHERIT (CAR ,IL:INHERITS))
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE
|
||||
IL:VARS IL:VAR IL:THIS-INHERIT `(PROGN (IL:SETQ ,IL:INHERITS (CDR ,IL:INHERITS))
|
||||
(GO ,IL:NEXT-INHERIT))
|
||||
`((WHEN (OR (NOT ,IL:SHADOWED)
|
||||
(EQ (FIND-SYMBOL (SYMBOL-NAME ,IL:VAR)
|
||||
,IL:N-PACKAGE)
|
||||
,@(IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR IL:THIS-INHERIT
|
||||
`(PROGN (IL:SETQ ,IL:INHERITS (CDR ,IL:INHERITS))
|
||||
(GO ,IL:NEXT-INHERIT))
|
||||
`((WHEN (OR (NOT ,IL:SHADOWED)
|
||||
(EQ (FIND-SYMBOL (SYMBOL-NAME ,IL:VAR)
|
||||
,IL:N-PACKAGE)
|
||||
,IL:VAR))
|
||||
,@IL:CODE))))))
|
||||
|
||||
(DEFMACRO DO-ALL-SYMBOLS ((IL:VAR &OPTIONAL IL:RESULT-FORM)
|
||||
|
||||
(DEFMACRO DO-ALL-SYMBOLS ((IL:VAR &OPTIONAL IL:RESULT-FORM)
|
||||
&BODY
|
||||
(IL:CODE IL:DECLS))
|
||||
"Do-All-Symbols (Var [Package [Result-Form]]) {Declaration}* {Tag | Statement}* Executes the Forms once for each symbol in each package with Var bound to the current symbol."
|
||||
(LET* ((IL:PACKAGE-LOOP (IL:GENSYM))
|
||||
(IL:TAG (IL:GENSYM))
|
||||
(IL:PACKAGE-LIST (IL:GENSYM))
|
||||
(IL:VARS (IL:MAKE-DO-SYMBOLS-VARS))
|
||||
(IL:PACKAGE-LIST (IL:GENSYM))
|
||||
(IL:VARS (IL:MAKE-DO-SYMBOLS-VARS))
|
||||
(IL:INTERNAL-CODE (IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-INTERNAL-SYMBOLS
|
||||
(CAR ,IL:PACKAGE-LIST))
|
||||
`(GO ,IL:TAG)
|
||||
IL:CODE))
|
||||
`(GO ,IL:TAG)
|
||||
IL:CODE))
|
||||
(IL:EXTERNAL-CODE (IL:MAKE-DO-SYMBOLS-CODE IL:VARS IL:VAR `(%PACKAGE-EXTERNAL-SYMBOLS
|
||||
(CAR ,IL:PACKAGE-LIST))
|
||||
`(PROGN (IL:SETQ ,IL:PACKAGE-LIST (CDR ,IL:PACKAGE-LIST))
|
||||
(GO ,IL:PACKAGE-LOOP))
|
||||
IL:CODE)))
|
||||
@@ -1494,12 +1609,10 @@
|
||||
(LET ((PACKAGE (IL:\\PACKAGIFY PACKAGE)))
|
||||
(IF IL:EXTERNAL-ONLY
|
||||
(DO-EXTERNAL-SYMBOLS (SYMBOL PACKAGE)
|
||||
(IF IL:EXTERNAL-ONLY
|
||||
(DO-EXTERNAL-SYMBOLS (SYMBOL PACKAGE)
|
||||
(IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
|
||||
(PUSH SYMBOL LIST)))
|
||||
(DO-SYMBOLS (SYMBOL PACKAGE)
|
||||
(PUSH SYMBOL LIST)))
|
||||
(DO-SYMBOLS (SYMBOL PACKAGE)
|
||||
(IF (IL:APROPOS-SEARCH SYMBOL IL:BASE IL:OFFSET IL:LENGTH IL:FATP)
|
||||
(PUSH SYMBOL LIST)))))))
|
||||
LIST))
|
||||
|
||||
@@ -1510,7 +1623,7 @@
|
||||
|
||||
(DEFUN IL:FIND-EXTERNAL-SYMBOL (STRING PACKAGE)
|
||||
(IL:SETQ STRING (IL:MKSTRING STRING)) (IL:* IL:\;
|
||||
(DEFUN IL:FIND-EXTERNAL-SYMBOL (STRING PACKAGE)
|
||||
"Convert symbols to strings (for the reader)")
|
||||
(LET* ((IL:BASE (IL:|ffetch| (IL:STRINGP IL:BASE) IL:|of| STRING))
|
||||
(IL:OFFSET (IL:|ffetch| (IL:STRINGP IL:OFFST) IL:|of| STRING))
|
||||
(IL:LENGTH (IL:|ffetch| (IL:STRINGP IL:LENGTH) IL:|of| STRING))
|
||||
@@ -1526,8 +1639,7 @@
|
||||
IL:RESULT))
|
||||
(VALUES IL:SYM (NOT (IL:IEQP IL:RESULT -1))))
|
||||
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
|
||||
(VALUES IL:SYM (NOT (IL:IEQP IL:RESULT -1))))
|
||||
(IL:WITH-SYMBOL (IL:FOUND SYMBOL (%PACKAGE-EXTERNAL-SYMBOLS PACKAGE)
|
||||
IL:BASE IL:OFFSET IL:LENGTH IL:FATP IL:HASH IL:EHASH NIL NIL)
|
||||
(VALUES SYMBOL IL:FOUND)))))
|
||||
|
||||
(DEFUN IL:FIND-EXACT-SYMBOL (SYMBOL PACKAGE)
|
||||
@@ -1562,32 +1674,40 @@
|
||||
|
||||
(IL:ADDTOVAR IL:LAMA )
|
||||
)
|
||||
(IL:ADDTOVAR IL:LAMA )
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:PUTPROPS IL:LLPACKAGE IL:COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1990 1991 1992))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL (9779 10219 (IL:\\UPCASEBASE 9779 . 10219)) (10221 11342 (IL:APROPOS-SEARCH 10221 .
|
||||
11342)) (12882 12964 (PACKAGE-NAME 12882 . 12964)) (12966 13058 (PACKAGE-NICKNAMES 12966 . 13058)) (
|
||||
13060 13168 (PACKAGE-SHADOWING-SYMBOLS 13060 . 13168)) (13170 13260 (PACKAGE-USE-LIST 13170 . 13260))
|
||||
(13262 13360 (PACKAGE-USED-BY-LIST 13262 . 13360)) (13362 14517 (IL:MAKE-PACKAGE-HASHTABLE 13362 .
|
||||
14517)) (14519 14681 (PRINT-PACKAGE 14519 . 14681)) (14683 15074 (PRINT-PACKAGE-HASHTABLE 14683 .
|
||||
15074)) (16142 16923 (MAKE-SYMBOL 16142 . 16923)) (18034 18444 (IL:\\PKG-FIND-FREE-PACKAGE-INDEX 18034
|
||||
. 18444)) (18501 18647 (IL:SETF-SYMBOL-PACKAGE 18501 . 18647)) (18649 18741 (SYMBOL-PACKAGE 18649 .
|
||||
18741)) (21512 21684 (IL:INTERNAL-SYMBOL-COUNT 21512 . 21684)) (21686 21804 (IL:EXTERNAL-SYMBOL-COUNT
|
||||
21686 . 21804)) (21806 22962 (IL:ENTER-NEW-NICKNAMES 21806 . 22962)) (22964 23390 (
|
||||
IL:MAKE-PRIME-HASHTABLE-SIZE 22964 . 23390)) (23392 25061 (MAKE-PACKAGE 23392 . 25061)) (25062 28355 (
|
||||
XCL:DEFPACKAGE 25075 . 28353)) (28404 28626 (FIND-PACKAGE 28404 . 28626)) (28628 31966 (USE-PACKAGE
|
||||
28628 . 31966)) (31968 32448 (IN-PACKAGE 31968 . 32448)) (32450 32724 (XCL:PKG-GOTO 32450 . 32724)) (
|
||||
32726 33826 (RENAME-PACKAGE 32726 . 33826)) (33828 35279 (XCL:DELETE-PACKAGE 33828 . 35279)) (35281
|
||||
38227 (EXPORT 35281 . 38227)) (38229 39472 (UNEXPORT 38229 . 39472)) (39474 41118 (IMPORT 39474 .
|
||||
41118)) (41120 42398 (SHADOWING-IMPORT 41120 . 42398)) (42400 43454 (SHADOW 42400 . 43454)) (43456
|
||||
44111 (UNUSE-PACKAGE 43456 . 44111)) (44175 44481 (LIST-ALL-PACKAGES 44175 . 44481)) (44538 48313 (
|
||||
IL:ADD-SYMBOL 44538 . 48313)) (52637 53940 (IL:INTERN* 52637 . 53940)) (53942 59790 (IL:FIND-SYMBOL*
|
||||
53942 . 59790)) (59792 61243 (INTERN 59792 . 61243)) (61245 61823 (FIND-SYMBOL 61245 . 61823)) (61881
|
||||
62781 (IL:NUKE-SYMBOL 61881 . 62781)) (62783 64903 (UNINTERN 62783 . 64903)) (64905 66048 (
|
||||
IL:MOBY-UNINTERN 64905 . 66048)) (66107 66179 (IL:\\INDEXATOMPNAME 66107 . 66179)) (66291 66438 (
|
||||
IL:MAKE-DO-SYMBOLS-VARS 66291 . 66438)) (66440 67895 (IL:MAKE-DO-SYMBOLS-CODE 66440 . 67895)) (75495
|
||||
76020 (FIND-ALL-SYMBOLS 75495 . 76020)) (76022 76301 (IL:BRIEFLY-DESCRIBE-SYMBOL 76022 . 76301)) (
|
||||
76303 77817 (APROPOS 76303 . 77817)) (77819 79476 (APROPOS-LIST 77819 . 79476)) (79580 81153 (
|
||||
IL:FIND-EXTERNAL-SYMBOL 79580 . 81153)) (81155 81675 (IL:FIND-EXACT-SYMBOL 81155 . 81675)) (81677
|
||||
(IL:FILEMAP (NIL (5304 5829 (IL:PACKAGE-LISTIFY 5304 . 5829)) (5831 6219 (IL:\\SIMPLE-STRINGIFY 5831
|
||||
. 6219)) (6221 6713 (IL:SYMBOL-LISTIFY 6221 . 6713)) (6715 6777 (IL:COPY-STRING 6715 . 6777)) (6779
|
||||
7517 (IL:\\SYMBOL-EQUALBASE 6779 . 7517)) (7521 7957 (IL:\\FATCHARSEENP 7521 . 7957)) (7959 8487 (
|
||||
IL:\\PACKAGIFY 7959 . 8487)) (8489 9526 (IL:\\STRING-EQUALBASE 8489 . 9526)) (9528 9752 (
|
||||
IL:NUMERIC-UPCASE 9528 . 9752)) (9754 10111 (IL:\\UPCASEBASE 9754 . 10111)) (10113 11230 (
|
||||
IL:APROPOS-SEARCH 10113 . 11230)) (12750 12832 (PACKAGE-NAME 12750 . 12832)) (12834 12926 (
|
||||
PACKAGE-NICKNAMES 12834 . 12926)) (12928 13036 (PACKAGE-SHADOWING-SYMBOLS 12928 . 13036)) (13038 13128
|
||||
(PACKAGE-USE-LIST 13038 . 13128)) (13130 13228 (PACKAGE-USED-BY-LIST 13130 . 13228)) (13230 14385 (
|
||||
IL:MAKE-PACKAGE-HASHTABLE 13230 . 14385)) (14387 14549 (PRINT-PACKAGE 14387 . 14549)) (14551 14942 (
|
||||
PRINT-PACKAGE-HASHTABLE 14551 . 14942)) (16006 16787 (MAKE-SYMBOL 16006 . 16787)) (17838 18248 (
|
||||
IL:\\PKG-FIND-FREE-PACKAGE-INDEX 17838 . 18248)) (18305 18451 (IL:SETF-SYMBOL-PACKAGE 18305 . 18451))
|
||||
(18453 18545 (SYMBOL-PACKAGE 18453 . 18545)) (18587 20224 (IL:SYMBOL-HASH 18587 . 20224)) (20226 20358
|
||||
(IL:REHASH-FACTOR 20226 . 20358)) (20360 20526 (IL:SYMBOL-HASH-REPROBE 20360 . 20526)) (20528 20919 (
|
||||
IL:ENTRY-HASH 20528 . 20919)) (20968 21314 (IL:COUNT-PACKAGE-HASHTABLE 20968 . 21314)) (21316 21488 (
|
||||
IL:INTERNAL-SYMBOL-COUNT 21316 . 21488)) (21490 21608 (IL:EXTERNAL-SYMBOL-COUNT 21490 . 21608)) (21610
|
||||
22766 (IL:ENTER-NEW-NICKNAMES 21610 . 22766)) (22768 23194 (IL:MAKE-PRIME-HASHTABLE-SIZE 22768 .
|
||||
23194)) (23196 24845 (MAKE-PACKAGE 23196 . 24845)) (24846 34317 (XCL:DEFPACKAGE 24859 . 34315)) (34366
|
||||
34588 (FIND-PACKAGE 34366 . 34588)) (34590 37951 (USE-PACKAGE 34590 . 37951)) (37953 38433 (
|
||||
IN-PACKAGE 37953 . 38433)) (38435 38709 (XCL:PKG-GOTO 38435 . 38709)) (38711 39811 (RENAME-PACKAGE
|
||||
38711 . 39811)) (39813 41264 (XCL:DELETE-PACKAGE 39813 . 41264)) (41266 44212 (EXPORT 41266 . 44212))
|
||||
(44214 45457 (UNEXPORT 44214 . 45457)) (45459 47103 (IMPORT 45459 . 47103)) (47105 48385 (
|
||||
SHADOWING-IMPORT 47105 . 48385)) (48387 49441 (SHADOW 48387 . 49441)) (49443 50098 (UNUSE-PACKAGE
|
||||
49443 . 50098)) (50162 50468 (LIST-ALL-PACKAGES 50162 . 50468)) (50525 54208 (IL:ADD-SYMBOL 50525 .
|
||||
54208)) (54210 58263 (IL:WITH-SYMBOL 54210 . 58263)) (58265 59568 (IL:INTERN* 58265 . 59568)) (59570
|
||||
65402 (IL:FIND-SYMBOL* 59570 . 65402)) (65404 66855 (INTERN 65404 . 66855)) (66857 67435 (FIND-SYMBOL
|
||||
66857 . 67435)) (67493 68389 (IL:NUKE-SYMBOL 67493 . 68389)) (68391 70505 (UNINTERN 68391 . 70505)) (
|
||||
70507 71650 (IL:MOBY-UNINTERN 70507 . 71650)) (71709 71781 (IL:\\INDEXATOMPNAME 71709 . 71781)) (71893
|
||||
72040 (IL:MAKE-DO-SYMBOLS-VARS 71893 . 72040)) (72042 73497 (IL:MAKE-DO-SYMBOLS-CODE 72042 . 73497))
|
||||
(73501 74279 (DO-EXTERNAL-SYMBOLS 73501 . 74279)) (74281 75627 (XCL:DO-LOCAL-SYMBOLS 74281 . 75627)) (
|
||||
75629 76745 (XCL:DO-INTERNAL-SYMBOLS 75629 . 76745)) (76747 79045 (DO-SYMBOLS 76747 . 79045)) (79047
|
||||
80729 (DO-ALL-SYMBOLS 79047 . 80729)) (80797 81322 (FIND-ALL-SYMBOLS 80797 . 81322)) (81324 81603 (
|
||||
IL:BRIEFLY-DESCRIBE-SYMBOL 81324 . 81603)) (81605 83119 (APROPOS 81605 . 83119)) (83121 84688 (
|
||||
APROPOS-LIST 83121 . 84688)) (84792 86319 (IL:FIND-EXTERNAL-SYMBOL 84792 . 86319)) (86321 86841 (
|
||||
IL:FIND-EXACT-SYMBOL 86321 . 86841)) (86843 86923 (IL:PACKAGE-NAME-AS-SYMBOL 86843 . 86923)) (86925
|
||||
87074 (IL:\\FIND.PACKAGE.INTERNAL 86925 . 87074)))))
|
||||
IL:STOP
|
||||
|
||||
Binary file not shown.
@@ -1,13 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "23-Apr-2024 18:08:13" {WMEDLEY}<sources>WINDOWOBJ.;26 32448
|
||||
(FILECREATED "17-Jul-2024 21:54:38" {WMEDLEY}<sources>WINDOWOBJ.;27 32550
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS ENCAPSULATEDOBJP)
|
||||
(VARS WINDOWOBJCOMS)
|
||||
:CHANGES-TO (FNS IMAGEFNSCREATE)
|
||||
|
||||
:PREVIOUS-DATE " 5-Dec-2023 21:15:38" {WMEDLEY}<sources>WINDOWOBJ.;23)
|
||||
:PREVIOUS-DATE "23-Apr-2024 18:08:13" {WMEDLEY}<sources>WINDOWOBJ.;26)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT WINDOWOBJCOMS)
|
||||
@@ -133,6 +132,7 @@
|
||||
(IMAGEFNSCREATE
|
||||
[LAMBDA (DISPLAYFN IMAGEBOXFN PUTFN GETFN COPYFN BUTTONEVENTINFN COPYBUTTONEVENTINFN WHENMOVEDFN
|
||||
WHENINSERTEDFN WHENDELETEDFN WHENCOPIEDFN WHENOPERATEDONFN PREPRINTFN CLASSNAME)
|
||||
(* ; "Edited 17-Jul-2024 21:54 by rmk")
|
||||
(* jds "19-Feb-85 09:33")
|
||||
|
||||
(* ;; "returns a structure which contains the image functions for a type of image object.")
|
||||
@@ -156,7 +156,8 @@
|
||||
WHENDELETEDFN _ WHENDELETEDFN
|
||||
WHENCOPIEDFN _ WHENCOPIEDFN
|
||||
WHENOPERATEDONFN _ WHENOPERATEDONFN
|
||||
PREPRINTFN _ PREPRINTFN])
|
||||
PREPRINTFN _ PREPRINTFN
|
||||
IMAGECLASSNAME _ CLASSNAME])
|
||||
|
||||
(IMAGEFNSP
|
||||
[LAMBDA (X) (* rrb " 1-Feb-84 11:13")
|
||||
@@ -595,11 +596,11 @@ Either delete this image object or load its support files." IMAGEOBJ)
|
||||
(ADDTOVAR LAMA IMAGEOBJPROP)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4826 23314 (COPYINSERT 4836 . 6363) (IMAGEBOX 6365 . 6545) (IMAGEFNSCREATE 6547 . 7742)
|
||||
(IMAGEFNSP 7744 . 7985) (IMAGEOBJCREATE 7987 . 8532) (IMAGEOBJP 8534 . 8775) (IMAGEOBJPROP 8777 .
|
||||
14669) (\IMAGEUSERPROP 14671 . 15265) (HPRINT.IMAGEOBJ 15267 . 15856) (COPYIMAGEOBJ 15858 . 16601) (
|
||||
READIMAGEOBJ 16603 . 21960) (WRITEIMAGEOBJ 21962 . 23312)) (23528 32170 (
|
||||
ENCAPSULATEDOBJ.BUTTONEVENTINFN 23538 . 25321) (ENCAPSULATEDOBJ.PUTFN 25323 . 26438) (
|
||||
ENCAPSULATEDOBJ.DISPLAYFN 26440 . 28243) (ENCAPSULATEDOBJ.IMAGEBOXFN 28245 . 30421) (ENCAPSULATEDOBJP
|
||||
30423 . 30731) (ENCAPSULATEDIMAGEFNS 30733 . 32168)))))
|
||||
(FILEMAP (NIL (4785 23416 (COPYINSERT 4795 . 6322) (IMAGEBOX 6324 . 6504) (IMAGEFNSCREATE 6506 . 7844)
|
||||
(IMAGEFNSP 7846 . 8087) (IMAGEOBJCREATE 8089 . 8634) (IMAGEOBJP 8636 . 8877) (IMAGEOBJPROP 8879 .
|
||||
14771) (\IMAGEUSERPROP 14773 . 15367) (HPRINT.IMAGEOBJ 15369 . 15958) (COPYIMAGEOBJ 15960 . 16703) (
|
||||
READIMAGEOBJ 16705 . 22062) (WRITEIMAGEOBJ 22064 . 23414)) (23630 32272 (
|
||||
ENCAPSULATEDOBJ.BUTTONEVENTINFN 23640 . 25423) (ENCAPSULATEDOBJ.PUTFN 25425 . 26540) (
|
||||
ENCAPSULATEDOBJ.DISPLAYFN 26542 . 28345) (ENCAPSULATEDOBJ.IMAGEBOXFN 28347 . 30523) (ENCAPSULATEDOBJP
|
||||
30525 . 30833) (ENCAPSULATEDIMAGEFNS 30835 . 32270)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
131
sources/XCL-LOOP
131
sources/XCL-LOOP
@@ -1,13 +1,13 @@
|
||||
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "LOOP" ( USE "LISP" "XCL")) READTABLE "XCL" BASE 10)
|
||||
|
||||
(il:filecreated " 8-Apr-2024 19:38:27" il:|{DSK}<home>larry>il>medley>sources>XCL-LOOP.;13| 61862
|
||||
(il:filecreated "14-Jun-2024 23:09:54" il:|{DSK}<home>matt>Interlisp>medley>sources>XCL-LOOP.;4| 62255
|
||||
|
||||
:edit-by "lmm"
|
||||
:edit-by "mth"
|
||||
|
||||
:changes-to (il:vars il:xcl-loopcoms)
|
||||
(il:functions cl::symbol-macrolet with-list-accumulator)
|
||||
:changes-to (il:functions default-type default-value)
|
||||
|
||||
:previous-date " 2-Apr-2024 15:08:27" il:|{DSK}<home>larry>il>medley>sources>XCL-LOOP.;12|)
|
||||
:previous-date " 8-Apr-2024 19:38:27" il:|{DSK}<home>matt>Interlisp>medley>sources>XCL-LOOP.;2|
|
||||
)
|
||||
|
||||
|
||||
(il:prettycomprint il:xcl-loopcoms)
|
||||
@@ -476,8 +476,12 @@
|
||||
(dig d-type-spec d-var-spec)
|
||||
bindings)))
|
||||
|
||||
(defun default-type (type)
|
||||
(if (eq type t)
|
||||
(defun default-type (type) (il:* il:\; "Edited 13-Jun-2024 20:05 by mth")
|
||||
|
||||
(il:* il:|;;| "Probably shouldn't ever happen, but if TYPE is NIL")
|
||||
|
||||
(if (or (null type)
|
||||
(eq type t))
|
||||
t
|
||||
(let ((value (default-value type)))
|
||||
(if (typep value type)
|
||||
@@ -489,8 +493,13 @@
|
||||
`(or null ,type)
|
||||
`(or ,default-type ,type))))))))
|
||||
|
||||
(defun default-value (type)
|
||||
(defun default-value (type) (il:* il:\; "Edited 13-Jun-2024 20:31 by mth")
|
||||
(cond
|
||||
((null type)
|
||||
|
||||
(il:* il:|;;| "giving NIL specifically as the VAR type probably shouldn't happen, but seems to be \"legal\", so handle it")
|
||||
|
||||
nil)
|
||||
((subtypep type 'bignum)
|
||||
(1+ most-positive-fixnum))
|
||||
((subtypep type 'integer)
|
||||
@@ -1389,7 +1398,7 @@
|
||||
|
||||
(il:putprops il:xcl-loop il:copyright (("Interlisp.org" 2004)
|
||||
("Yuji Minejima <ggb01164@nifty.ne.jp>")
|
||||
2002 2004))
|
||||
2002 2004 2024))
|
||||
|
||||
(il:putprops il:xcl-loop il:license "See COPYRIGHT and LICENSE in the repository
|
||||
;; $Id: loop.lisp,v 1.38 2005/04/16 07:34:27 yuji Exp $
|
||||
@@ -1417,56 +1426,56 @@
|
||||
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
|
||||
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.")
|
||||
(il:declare\: il:dontcopy
|
||||
(il:filemap (nil (6825 6910 (%keyword 6825 . 6910)) (6912 7095 (%list 6912 . 7095)) (7097 8354 (
|
||||
accumulate-in-list 7097 . 8354)) (8356 10036 (accumulation-clause 8356 . 10036)) (10038 10272 (
|
||||
accumulator-kind 10038 . 10272)) (10274 12163 (accumulator-spec 10274 . 12163)) (12165 12634 (
|
||||
along-with 12165 . 12634)) (12636 13128 (always-never-thereis-clause 12636 . 13128)) (13130 13489 (
|
||||
ambiguous-loop-result-error 13130 . 13489)) (13491 13706 (append-context 13491 . 13706)) (13785 14162
|
||||
(bindings 13785 . 14162)) (14164 14504 (bound-variables 14164 . 14504)) (14506 14596 (by-step-fun
|
||||
14506 . 14596)) (14598 14704 (car-type 14598 . 14704)) (14706 14812 (cdr-type 14706 . 14812)) (14814
|
||||
15211 (check-multiple-bindings 14814 . 15211)) (15213 15433 (cl-external-p 15213 . 15433)) (15435
|
||||
15564 (clause* 15435 . 15564)) (15566 15966 (clause1 15566 . 15966)) (15968 16125 (compound-forms*
|
||||
15968 . 16125)) (16127 16251 (compound-forms+ 16127 . 16251)) (16253 17511 (conditional-clause 16253
|
||||
. 17511)) (17513 18224 (constant-bindings 17513 . 18224)) (18226 18597 (constant-function-p 18226 .
|
||||
18597)) (18599 18793 (constant-vector 18599 . 18793)) (18795 18886 (constant-vector-p 18795 . 18886))
|
||||
(18888 19080 (d-var-spec-p 18888 . 19080)) (19082 19312 (d-var-spec1 19082 . 19312)) (19314 19639 (
|
||||
d-var-type-spec 19314 . 19639)) (19641 20201 (declarations 19641 . 20201)) (20203 20313 (
|
||||
default-binding 20203 . 20313)) (20315 20928 (default-bindings 20315 . 20928)) (20930 21391 (
|
||||
default-type 20930 . 21391)) (21393 21914 (default-value 21393 . 21914)) (21916 23406 (
|
||||
destructuring-multiple-value-bind 21916 . 23406)) (23408 24693 (destructuring-multiple-value-setq
|
||||
23408 . 24693)) (24695 25222 (dispatch-for-as-subclause 24695 . 25222)) (25224 25293 (do-clause 25224
|
||||
. 25293)) (25295 25471 (empty-p 25295 . 25471)) (25473 25747 (enumerate 25473 . 25747)) (25749 27475
|
||||
(extended-loop 25749 . 27475)) (27477 27648 (fill-in 27477 . 27648)) (27650 27727 (finally-clause
|
||||
27650 . 27727)) (27729 27847 (for 27729 . 27847)) (27849 29205 (for-as-across-subclause 27849 . 29205)
|
||||
) (29207 30129 (for-as-arithmetic-possible-prepositions 29207 . 30129)) (30131 30847 (
|
||||
for-as-arithmetic-step-and-test-functions 30131 . 30847)) (30849 32794 (for-as-arithmetic-subclause
|
||||
30849 . 32794)) (32796 33246 (for-as-being-subclause 32796 . 33246)) (33248 34464 (for-as-clause 33248
|
||||
. 34464)) (34466 35994 (for-as-equals-then-subclause 34466 . 35994)) (35996 36274 (for-as-fill-in
|
||||
35996 . 36274)) (36276 38242 (for-as-hash-subclause 36276 . 38242)) (38244 38490 (
|
||||
for-as-in-list-subclause 38244 . 38490)) (38492 39985 (for-as-on-list-subclause 38492 . 39985)) (39987
|
||||
41689 (for-as-package-subclause 39987 . 41689)) (41691 41922 (for-as-parallel-p 41691 . 41922)) (
|
||||
41924 42072 (form-or-it 41924 . 42072)) (42074 42193 (form1 42074 . 42193)) (42195 42295 (
|
||||
gensym-ignorable 42195 . 42295)) (42297 42408 (globally-special-p 42297 . 42408)) (42410 42589 (
|
||||
hash-d-var-spec 42410 . 42589)) (42591 42672 (initially-clause 42591 . 42672)) (42674 42831 (
|
||||
invalid-accumulator-combination-error 42674 . 42831)) (42833 43450 (keyword1 42833 . 43450)) (43452
|
||||
43922 (keyword? 43452 . 43922)) (43924 44033 (let-form 43924 . 44033)) (44035 44189 (loop-error 44035
|
||||
. 44189)) (44191 44382 (loop-finish-test-forms 44191 . 44382)) (44384 44536 (loop-warn 44384 . 44536)
|
||||
) (44538 44742 (lp 44538 . 44742)) (44744 45181 (main-clause* 44744 . 45181)) (45183 45279 (mapappend
|
||||
45183 . 45279)) (45281 45811 (multiple-value-list-argument-form 45281 . 45811)) (45813 46206 (
|
||||
multiple-value-list-form-p 45813 . 46206)) (46208 46546 (name-clause? 46208 . 46546)) (46548 46827 (
|
||||
one 46548 . 46827)) (46829 48474 (ordinary-bindings 46829 . 48474)) (48476 48693 (preposition1 48476
|
||||
. 48693)) (48695 48896 (preposition? 48695 . 48896)) (48898 49058 (psetq-forms 48898 . 49058)) (49060
|
||||
49240 (quoted-form-p 49060 . 49240)) (49242 49497 (quoted-object 49242 . 49497)) (49499 50303 (
|
||||
reduce-redundant-code 49499 . 50303)) (50305 50534 (repeat-clause 50305 . 50534)) (50536 50626 (
|
||||
return-clause 50536 . 50626)) (50628 51463 (selectable-clause 50628 . 51463)) (51465 51616 (
|
||||
simple-loop 51465 . 51616)) (51618 51696 (simple-var-p 51618 . 51696)) (51698 51882 (simple-var1 51698
|
||||
. 51882)) (51884 51991 (stray-of-type-error 51884 . 51991)) (51993 52278 (cl::symbol-macrolet 51993
|
||||
. 52278)) (52280 52714 (type-spec? 52280 . 52714)) (52716 52782 (until-clause 52716 . 52782)) (52784
|
||||
53365 (using-other-var 52784 . 53365)) (53367 53561 (variable-clause* 53367 . 53561)) (53563 53667 (
|
||||
while-clause 53563 . 53667)) (53669 53848 (with 53669 . 53848)) (53850 54295 (with-accumulators 53850
|
||||
. 54295)) (54297 54547 (with-binding-forms 54297 . 54547)) (54549 55780 (with-clause 54549 . 55780))
|
||||
(55782 56041 (with-iterator-forms 55782 . 56041)) (56043 57190 (with-list-accumulator 56043 . 57190))
|
||||
(57192 57629 (with-loop-context 57192 . 57629)) (57631 58869 (with-numeric-accumulator 57631 . 58869))
|
||||
(58871 59392 (with-temporaries 58871 . 59392)) (59394 59674 (zero 59394 . 59674)) (59676 59809 (loop
|
||||
59676 . 59809)))))
|
||||
(il:filemap (nil (6777 6862 (%keyword 6777 . 6862)) (6864 7047 (%list 6864 . 7047)) (7049 8306 (
|
||||
accumulate-in-list 7049 . 8306)) (8308 9988 (accumulation-clause 8308 . 9988)) (9990 10224 (
|
||||
accumulator-kind 9990 . 10224)) (10226 12115 (accumulator-spec 10226 . 12115)) (12117 12586 (
|
||||
along-with 12117 . 12586)) (12588 13080 (always-never-thereis-clause 12588 . 13080)) (13082 13441 (
|
||||
ambiguous-loop-result-error 13082 . 13441)) (13443 13658 (append-context 13443 . 13658)) (13737 14114
|
||||
(bindings 13737 . 14114)) (14116 14456 (bound-variables 14116 . 14456)) (14458 14548 (by-step-fun
|
||||
14458 . 14548)) (14550 14656 (car-type 14550 . 14656)) (14658 14764 (cdr-type 14658 . 14764)) (14766
|
||||
15163 (check-multiple-bindings 14766 . 15163)) (15165 15385 (cl-external-p 15165 . 15385)) (15387
|
||||
15516 (clause* 15387 . 15516)) (15518 15918 (clause1 15518 . 15918)) (15920 16077 (compound-forms*
|
||||
15920 . 16077)) (16079 16203 (compound-forms+ 16079 . 16203)) (16205 17463 (conditional-clause 16205
|
||||
. 17463)) (17465 18176 (constant-bindings 17465 . 18176)) (18178 18549 (constant-function-p 18178 .
|
||||
18549)) (18551 18745 (constant-vector 18551 . 18745)) (18747 18838 (constant-vector-p 18747 . 18838))
|
||||
(18840 19032 (d-var-spec-p 18840 . 19032)) (19034 19264 (d-var-spec1 19034 . 19264)) (19266 19591 (
|
||||
d-var-type-spec 19266 . 19591)) (19593 20153 (declarations 19593 . 20153)) (20155 20265 (
|
||||
default-binding 20155 . 20265)) (20267 20880 (default-bindings 20267 . 20880)) (20882 21530 (
|
||||
default-type 20882 . 21530)) (21532 22302 (default-value 21532 . 22302)) (22304 23794 (
|
||||
destructuring-multiple-value-bind 22304 . 23794)) (23796 25081 (destructuring-multiple-value-setq
|
||||
23796 . 25081)) (25083 25610 (dispatch-for-as-subclause 25083 . 25610)) (25612 25681 (do-clause 25612
|
||||
. 25681)) (25683 25859 (empty-p 25683 . 25859)) (25861 26135 (enumerate 25861 . 26135)) (26137 27863
|
||||
(extended-loop 26137 . 27863)) (27865 28036 (fill-in 27865 . 28036)) (28038 28115 (finally-clause
|
||||
28038 . 28115)) (28117 28235 (for 28117 . 28235)) (28237 29593 (for-as-across-subclause 28237 . 29593)
|
||||
) (29595 30517 (for-as-arithmetic-possible-prepositions 29595 . 30517)) (30519 31235 (
|
||||
for-as-arithmetic-step-and-test-functions 30519 . 31235)) (31237 33182 (for-as-arithmetic-subclause
|
||||
31237 . 33182)) (33184 33634 (for-as-being-subclause 33184 . 33634)) (33636 34852 (for-as-clause 33636
|
||||
. 34852)) (34854 36382 (for-as-equals-then-subclause 34854 . 36382)) (36384 36662 (for-as-fill-in
|
||||
36384 . 36662)) (36664 38630 (for-as-hash-subclause 36664 . 38630)) (38632 38878 (
|
||||
for-as-in-list-subclause 38632 . 38878)) (38880 40373 (for-as-on-list-subclause 38880 . 40373)) (40375
|
||||
42077 (for-as-package-subclause 40375 . 42077)) (42079 42310 (for-as-parallel-p 42079 . 42310)) (
|
||||
42312 42460 (form-or-it 42312 . 42460)) (42462 42581 (form1 42462 . 42581)) (42583 42683 (
|
||||
gensym-ignorable 42583 . 42683)) (42685 42796 (globally-special-p 42685 . 42796)) (42798 42977 (
|
||||
hash-d-var-spec 42798 . 42977)) (42979 43060 (initially-clause 42979 . 43060)) (43062 43219 (
|
||||
invalid-accumulator-combination-error 43062 . 43219)) (43221 43838 (keyword1 43221 . 43838)) (43840
|
||||
44310 (keyword? 43840 . 44310)) (44312 44421 (let-form 44312 . 44421)) (44423 44577 (loop-error 44423
|
||||
. 44577)) (44579 44770 (loop-finish-test-forms 44579 . 44770)) (44772 44924 (loop-warn 44772 . 44924)
|
||||
) (44926 45130 (lp 44926 . 45130)) (45132 45569 (main-clause* 45132 . 45569)) (45571 45667 (mapappend
|
||||
45571 . 45667)) (45669 46199 (multiple-value-list-argument-form 45669 . 46199)) (46201 46594 (
|
||||
multiple-value-list-form-p 46201 . 46594)) (46596 46934 (name-clause? 46596 . 46934)) (46936 47215 (
|
||||
one 46936 . 47215)) (47217 48862 (ordinary-bindings 47217 . 48862)) (48864 49081 (preposition1 48864
|
||||
. 49081)) (49083 49284 (preposition? 49083 . 49284)) (49286 49446 (psetq-forms 49286 . 49446)) (49448
|
||||
49628 (quoted-form-p 49448 . 49628)) (49630 49885 (quoted-object 49630 . 49885)) (49887 50691 (
|
||||
reduce-redundant-code 49887 . 50691)) (50693 50922 (repeat-clause 50693 . 50922)) (50924 51014 (
|
||||
return-clause 50924 . 51014)) (51016 51851 (selectable-clause 51016 . 51851)) (51853 52004 (
|
||||
simple-loop 51853 . 52004)) (52006 52084 (simple-var-p 52006 . 52084)) (52086 52270 (simple-var1 52086
|
||||
. 52270)) (52272 52379 (stray-of-type-error 52272 . 52379)) (52381 52666 (cl::symbol-macrolet 52381
|
||||
. 52666)) (52668 53102 (type-spec? 52668 . 53102)) (53104 53170 (until-clause 53104 . 53170)) (53172
|
||||
53753 (using-other-var 53172 . 53753)) (53755 53949 (variable-clause* 53755 . 53949)) (53951 54055 (
|
||||
while-clause 53951 . 54055)) (54057 54236 (with 54057 . 54236)) (54238 54683 (with-accumulators 54238
|
||||
. 54683)) (54685 54935 (with-binding-forms 54685 . 54935)) (54937 56168 (with-clause 54937 . 56168))
|
||||
(56170 56429 (with-iterator-forms 56170 . 56429)) (56431 57578 (with-list-accumulator 56431 . 57578))
|
||||
(57580 58017 (with-loop-context 57580 . 58017)) (58019 59257 (with-numeric-accumulator 58019 . 59257))
|
||||
(59259 59780 (with-temporaries 59259 . 59780)) (59782 60062 (zero 59782 . 60062)) (60064 60197 (loop
|
||||
60064 . 60197)))))
|
||||
il:stop
|
||||
|
||||
Binary file not shown.
Reference in New Issue
Block a user