Compare commits
7 Commits
rmk164--Up
...
lmm30-use-
| Author | SHA1 | Date | |
|---|---|---|---|
|
5a24a52819 | ||
|
|
34dfed15a1 | ||
|
|
6196019fcf | ||
|
d9f1a78f47 | ||
|
|
ab4eb3d52d | ||
|
|
0f470b9753 | ||
|
|
b1bdd90338 |
14
.github/workflows/buildLoadup.yml
vendored
14
.github/workflows/buildLoadup.yml
vendored
@@ -124,6 +124,8 @@ jobs:
|
||||
# Checkout latest commit
|
||||
- name: Checkout Medley
|
||||
uses: actions/checkout@v4
|
||||
with:
|
||||
submodules: true
|
||||
|
||||
# Setup release tag
|
||||
- name: Setup Release Tag
|
||||
@@ -191,18 +193,6 @@ jobs:
|
||||
env:
|
||||
GITHUB_TOKEN: ${{ secrets.MAIKO_TOKEN }}
|
||||
|
||||
# Checkout Notecards and tar it in the tarballsdir
|
||||
- name: Checkout Notecards
|
||||
uses: actions/checkout@v4
|
||||
with:
|
||||
repository: ${{ github.repository_owner }}/notecards
|
||||
path: ./notecards
|
||||
- name: Tar notecards into tarball dir
|
||||
run: |
|
||||
mv ./notecards ../notecards
|
||||
cd ../notecards
|
||||
git archive --format=tgz --output="${TARBALL_DIR}/notecards.tgz" --prefix=notecards/ main
|
||||
|
||||
# Install vnc
|
||||
- name: Install vnc
|
||||
run: sudo apt-get update && sudo apt-get install -y tightvncserver
|
||||
|
||||
27
.github/workflows/doHCFILES.yml
vendored
27
.github/workflows/doHCFILES.yml
vendored
@@ -51,33 +51,8 @@ jobs:
|
||||
|
||||
- name: Checkout Medley repo
|
||||
uses: actions/checkout@v4
|
||||
|
||||
- name: Checkout maiko
|
||||
uses: actions/checkout@v4
|
||||
with:
|
||||
repository: ${{ github.repository_owner }}/maiko
|
||||
path: ./maiko
|
||||
|
||||
- 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
|
||||
submodules: true
|
||||
|
||||
- name: Download Maiko
|
||||
run: |
|
||||
|
||||
3
.gitignore
vendored
3
.gitignore
vendored
@@ -5,9 +5,6 @@ tmp/*
|
||||
# releases directory
|
||||
releases/*
|
||||
|
||||
# maiko directory
|
||||
maiko/
|
||||
|
||||
|
||||
# all PDFs (those explicitly checked in aren't ignored
|
||||
# normally when you have derived files, you ignore them from git
|
||||
|
||||
20
.gitmodules
vendored
20
.gitmodules
vendored
@@ -0,0 +1,20 @@
|
||||
[submodule "maiko"]
|
||||
path = maiko
|
||||
url = https://github.com/Interlisp/maiko
|
||||
branch = master
|
||||
[submodule "notecards"]
|
||||
path = notecards
|
||||
url = https://github.com/Interlisp/notecards
|
||||
branch = main
|
||||
[submodule "loops"]
|
||||
path = loops
|
||||
url = https://github.com/Interlisp/loops
|
||||
branch = main
|
||||
[submodule "test"]
|
||||
path = test
|
||||
url = https://github.com/Interlisp/test
|
||||
branch = master
|
||||
[submodule "online"]
|
||||
path = online
|
||||
url = https://github.com/Interlisp/online
|
||||
branch = main
|
||||
|
||||
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 5-Feb-2026 10:26:39" {WMEDLEY}<internal>loadups>LOADUP-FULL.;36 5858
|
||||
(FILECREATED "14-Feb-2026 00:42:39" {WMEDLEY}<internal>loadups>LOADUP-FULL.;38 5967
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS LOADUP-FULL)
|
||||
|
||||
:PREVIOUS-DATE "28-Dec-2025 12:06:12" {WMEDLEY}<internal>loadups>LOADUP-FULL.;35)
|
||||
:PREVIOUS-DATE "13-Feb-2026 00:47:52" {WMEDLEY}<internal>loadups>LOADUP-FULL.;37)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT LOADUP-FULLCOMS)
|
||||
@@ -47,7 +47,8 @@
|
||||
(PRINTOUT T "FULL fonts loaded" T])
|
||||
|
||||
(LOADUP-FULL
|
||||
[LAMBDA (DRIBBLEFILE) (* ; "Edited 5-Feb-2026 10:26 by rmk")
|
||||
[LAMBDA (DRIBBLEFILE) (* ; "Edited 14-Feb-2026 00:42 by rmk")
|
||||
(* ; "Edited 5-Feb-2026 10:26 by rmk")
|
||||
(* ; "Edited 28-Dec-2025 12:06 by rmk")
|
||||
(* ; "Edited 1-Sep-2025 11:59 by rmk")
|
||||
(* ; "Edited 18-Aug-2025 12:09 by rmk")
|
||||
@@ -78,7 +79,6 @@
|
||||
(DIRECTORYNAME T)
|
||||
T T) (* ; "For FONTSAVAILABLE lookup")
|
||||
(LOADUP '(POSTSCRIPTSTREAM)) (* ; " to get PSCFONT.READFONT")
|
||||
(LOADFULLFONTS)
|
||||
(LISTPUT IDLE.PROFILE 'TIMEOUT 0)
|
||||
(SETQQ *DEFAULT-CLEANUP-COMPILER* BCOMPL)
|
||||
|
||||
@@ -88,6 +88,7 @@
|
||||
GRAPHER SPY WHERE-IS COPYFILES MSANALYZE MSPARSE MASTERSCOPE UNIXPRINT HELPSYS
|
||||
DINFO CLIPBOARD MODERNIZE WHEELSCROLL PRETTYFILEINDEX WHO-LINE UNIXCOMM UNIXCHAT
|
||||
UNIXYCD))
|
||||
(LOADFULLFONTS)
|
||||
(COND
|
||||
((WINDOWP *WHO-LINE*)
|
||||
(CLOSEW *WHO-LINE*)))
|
||||
@@ -102,5 +103,5 @@
|
||||
|
||||
(FIXMETA)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (456 5820 (LOADFULLFONTS 466 . 2601) (LOADUP-FULL 2603 . 5570) (FIXMETA 5572 . 5818)))))
|
||||
(FILEMAP (NIL (456 5929 (LOADFULLFONTS 466 . 2601) (LOADUP-FULL 2603 . 5679) (FIXMETA 5681 . 5927)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,13 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "XCL" BASE 10)
|
||||
|
||||
(FILECREATED "28-Jan-2026 14:30:48" |{DSK}<Users>larry>IL>medley>internal>loadups>LOADUP-LISP.;2| 7369
|
||||
(FILECREATED "22-Feb-2026 14:15:31" |{WMEDLEY}<internal>loadups>LOADUP-LISP.;27| 7420
|
||||
|
||||
:EDIT-BY "lmm"
|
||||
:EDIT-BY |rmk|
|
||||
|
||||
:CHANGES-TO (FNS LOADUP-LISP)
|
||||
|
||||
:PREVIOUS-DATE "27-Dec-2025 15:02:04"
|
||||
|{DSK}<Users>larry>IL>medley>internal>loadups>LOADUP-LISP.;1|)
|
||||
:PREVIOUS-DATE "22-Feb-2026 09:49:23" |{WMEDLEY}<internal>loadups>LOADUP-LISP.;26|)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT LOADUP-LISPCOMS)
|
||||
@@ -20,7 +19,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(LOADUP-LISP
|
||||
(LAMBDA (DRIBBLEFILE) (* \; "Edited 28-Jan-2026 14:30 by lmm")
|
||||
(LAMBDA (DRIBBLEFILE) (* \; "Edited 22-Feb-2026 14:15 by rmk")
|
||||
(* \; "Edited 28-Jan-2026 14:30 by lmm")
|
||||
(* \; "Edited 27-Dec-2025 15:02 by rmk")
|
||||
(* \; "Edited 16-Oct-2025 16:55 by rmk")
|
||||
(* \; "Edited 18-Aug-2025 12:08 by rmk")
|
||||
@@ -95,9 +95,9 @@
|
||||
|
||||
(* |;;| "Also, UNICODE is split into UNICODE-TABLES and UNICODE, so the tables are loaded before their MCCS/Uncode client functions are installed. Functions in UFS now depend on those translations so that filenames can have characters outside of Ascii. ")
|
||||
|
||||
(LOADUP '(UNICODE-TABLES UNICODE CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY FONTPROFILE MENU
|
||||
WINDOWOBJ WINDOWSCROLL WINDOW WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL
|
||||
DEXEC INSPECT DESCRIBE CMLARRAYINSPECTOR EDITINTERFACE TTYIN))
|
||||
(LOADUP '(CMLPATHNAME HPRINT AARITH ADISPLAY HLDISPLAY FONTPROFILE MENU WINDOWOBJ WINDOWSCROLL
|
||||
WINDOW WINDOWICON PAINTW ATTACHEDWINDOW XXGEOM XXFILL DEXEC INSPECT DESCRIBE
|
||||
CMLARRAYINSPECTOR EDITINTERFACE TTYIN))
|
||||
(LOADUP '(BREAK-AND-TRACE))
|
||||
(LOADUP '(FASDUMP XCL-COMPILER ADVISE))
|
||||
|
||||
@@ -147,5 +147,5 @@
|
||||
(GLOBALVARS MAKESYSFILENAME MEDLEY-INIT-VARS MEDLEYDIR SYSTEMINITVARS USERRECLST)
|
||||
)
|
||||
(DECLARE\: DONTCOPY
|
||||
(FILEMAP (NIL (675 7163 (LOADUP-LISP 685 . 7161)))))
|
||||
(FILEMAP (NIL (640 7214 (LOADUP-LISP 650 . 7212)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
@@ -1,13 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED "25-Sep-2025 15:00:01"
|
||||
{DSK}<Users>kaplan>Local>medley3.5>working-medley>library>CLIPBOARD.;28 8305
|
||||
(FILECREATED "23-Feb-2026 12:35:55" {WMEDLEY}<library>CLIPBOARD.;29 8228
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS PUTCLIPBOARD CLIPBOARD-COPY-STREAM)
|
||||
:CHANGES-TO (VARS CLIPBOARDCOMS)
|
||||
|
||||
:PREVIOUS-DATE "21-Apr-2024 09:12:04" {WMEDLEY}<library>CLIPBOARD.;18)
|
||||
:PREVIOUS-DATE "25-Sep-2025 15:00:01" {WMEDLEY}<library>CLIPBOARD.;28)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT CLIPBOARDCOMS)
|
||||
@@ -18,7 +17,7 @@
|
||||
CLIPBOARD-PASTE-STREAM)
|
||||
(FNS SEDIT.COPYTOCLIPBOARD)
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY (FILES (SYSLOAD)
|
||||
UNIXCOMM UNICODE)
|
||||
UNIXCOMM)
|
||||
(P (INSTALL-CLIPBOARD)))
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
|
||||
(NLAML)
|
||||
@@ -148,7 +147,7 @@
|
||||
(DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DOCOPY
|
||||
|
||||
(FILESLOAD (SYSLOAD)
|
||||
UNIXCOMM UNICODE)
|
||||
UNIXCOMM)
|
||||
|
||||
|
||||
(INSTALL-CLIPBOARD)
|
||||
@@ -162,7 +161,7 @@
|
||||
(ADDTOVAR LAMA )
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1167 6486 (INSTALL-CLIPBOARD 1177 . 2504) (GETCLIPBOARD 2506 . 2880) (PUTCLIPBOARD 2882
|
||||
. 4306) (PASTEFROMCLIPBOARD 4308 . 5226) (CLIPBOARD-COPY-STREAM 5228 . 5762) (CLIPBOARD-PASTE-STREAM
|
||||
5764 . 6484)) (6487 8026 (SEDIT.COPYTOCLIPBOARD 6497 . 8024)))))
|
||||
(FILEMAP (NIL (1098 6417 (INSTALL-CLIPBOARD 1108 . 2435) (GETCLIPBOARD 2437 . 2811) (PUTCLIPBOARD 2813
|
||||
. 4237) (PASTEFROMCLIPBOARD 4239 . 5157) (CLIPBOARD-COPY-STREAM 5159 . 5693) (CLIPBOARD-PASTE-STREAM
|
||||
5695 . 6415)) (6418 7957 (SEDIT.COPYTOCLIPBOARD 6428 . 7955)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
1508
library/UNICODE
1508
library/UNICODE
File diff suppressed because it is too large
Load Diff
@@ -1,19 +1,22 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
|
||||
|
||||
(FILECREATED "22-Oct-2025 23:28:42" {WMEDLEY}<library>UNICODE-TABLES.;4 34028
|
||||
(FILECREATED "22-Feb-2026 10:44:33" {WMEDLEY}<library>UNICODE-TABLES.;20 44960
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (VARS UNICODE-TABLESCOMS)
|
||||
:CHANGES-TO (FNS ALL-UNICODE-MAPPINGS GET-MCCS-UNICODE-MAPPING INVERT-UNICODE-MAPPING
|
||||
MAKE-UNICODE-TRANSLATION-TABLES MERGE-UNICODE-TRANSLATION-TABLES
|
||||
READ-UNICODE-MAPPING-FILENAMES)
|
||||
(VARS UNICODE-TABLESCOMS)
|
||||
|
||||
:PREVIOUS-DATE "16-Oct-2025 16:47:54" {WMEDLEY}<library>UNICODE-TABLES.;3)
|
||||
:PREVIOUS-DATE "22-Feb-2026 09:15:20" {WMEDLEY}<library>UNICODE-TABLES.;16)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT UNICODE-TABLESCOMS)
|
||||
|
||||
(RPAQQ UNICODE-TABLESCOMS
|
||||
[
|
||||
(* ;; "Read Unicode mapping tables. A separate file before UNICODE in the loadup, because the tables must be loaded while UTF8TOMCODE and MCODETOUTF8 are still equivalenced to EVQ. This file has to come before UNICODE in the loadup sequence.")
|
||||
(* ;; "This is code for reading/writing the XCCS-to-UNICODE mapping tables. It runs offline, when UNICODE-UTF8 is modified. ")
|
||||
|
||||
(COMS (* ; "Read Unicode mapping files")
|
||||
(INITVARS (UNICODEDIRECTORIES NIL))
|
||||
@@ -22,22 +25,32 @@
|
||||
(FNS READ-UNICODE-MAPPING-FILENAMES READ-UNICODE-MAPPING))
|
||||
(COMS (* ;
|
||||
"Make translation tables for UTF external formats")
|
||||
(FNS MAKE-UNICODE-TRANSLATION-TABLES XCCSTOMCCS-MAPPING
|
||||
MERGE-UNICODE-TRANSLATION-TABLES UNICODE.UNMAPPED UNICODE-EXTEND-TRANSLATION?)
|
||||
(FNS MAKE-UNICODE-TRANSLATION-TABLES GET-MCCS-UNICODE-MAPPING INVERT-UNICODE-MAPPING
|
||||
XCCSTOMCCS-MAPPING)
|
||||
(FNS ALL-UNICODE-MAPPINGS XCCSJAPANESECHARSETS)
|
||||
(INITVARS (*MCCSTOUNICODE*)
|
||||
(*UNICODETOMCCS*)
|
||||
(*MCCS-LOADED-CHARSETS*)
|
||||
(*UNICODE-LOADED-CHARSETS*)
|
||||
(*LARGEUNICODES*))
|
||||
[DECLARE%: DONTEVAL@LOAD DOCOPY (P (MAKE-UNICODE-TRANSLATION-TABLES 'ALL]
|
||||
(COMS (* ; "Write Unicode mapping files")
|
||||
(FNS WRITE-UNICODE-MAPPING WRITE-UNICODE-INCLUDED WRITE-UNICODE-MAPPING-HEADER
|
||||
WRITE-UNICODE-MAPPING-FILENAME)
|
||||
(FNS XCCS-UTF8-AFTER-OPEN)
|
||||
|
||||
(* ;; "Automate dumping of a documentation prefix")
|
||||
|
||||
[DECLARE%: EVAL@COMPILE DONTCOPY (CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE"
|
||||
:RADIX 16))
|
||||
(UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF"
|
||||
:RADIX 16]
|
||||
(VARS UNICODE-MAPPING-HEADER))
|
||||
(FNS UTF8HEXSTRING)
|
||||
(COMS (* ; "debugging")
|
||||
(FNS SHOWCHARS)
|
||||
(DECLARE%: DOEVAL@LOAD DONTCOPY (MACROS HEXCHAR OCTALCHAR)))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
|
||||
UNICODE-EXPORTS])
|
||||
|
||||
|
||||
|
||||
(* ;;
|
||||
"Read Unicode mapping tables. A separate file before UNICODE in the loadup, because the tables must be loaded while UTF8TOMCODE and MCODETOUTF8 are still equivalenced to EVQ. This file has to come before UNICODE in the loadup sequence."
|
||||
"This is code for reading/writing the XCCS-to-UNICODE mapping tables. It runs offline, when UNICODE-UTF8 is modified. "
|
||||
)
|
||||
|
||||
|
||||
@@ -94,7 +107,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(READ-UNICODE-MAPPING-FILENAMES
|
||||
[LAMBDA (FILESPEC) (* ; "Edited 16-Oct-2025 16:43 by rmk")
|
||||
[LAMBDA (FILESPEC) (* ; "Edited 21-Feb-2026 18:14 by rmk")
|
||||
(* ; "Edited 16-Oct-2025 16:43 by rmk")
|
||||
(* ; "Edited 4-Sep-2025 00:11 by rmk")
|
||||
(* ; "Edited 27-Jan-2025 16:46 by rmk")
|
||||
(* ; "Edited 21-Jan-2025 22:51 by rmk")
|
||||
@@ -107,51 +121,47 @@
|
||||
|
||||
(* ;; "FILESPEC can be a file name, character-set name, the name of a collection of character sets, an XCCS character code, or a list of those. Maps those into the names of files that contain the indicated Unicode mappings.")
|
||||
|
||||
(CL:REMOVE-DUPLICATES [for F X CSI inside (if (EQ FILESPEC 'ALL)
|
||||
then
|
||||
(* ;;
|
||||
(for F X CSI inside (if (EQ FILESPEC 'ALL)
|
||||
then
|
||||
(* ;;
|
||||
"Perhaps should figure out which files in the directories and subdirectories are relevant?")
|
||||
|
||||
(for N in XCCS-CHARSETS
|
||||
collect (CAR N))
|
||||
else FILESPEC)
|
||||
join
|
||||
(* ;; "Last case hopes to pick up all the tables that are grouped together in a subdirectory (e.g. if F is JIS)")
|
||||
(for N in XCCS-CHARSETS collect (CAR N))
|
||||
else FILESPEC)
|
||||
join
|
||||
(* ;; "Last case hopes to pick up all the tables that are grouped together in a subdirectory (e.g. if F is JIS)")
|
||||
|
||||
(OR (CL:WHEN (CHARCODEP F) (* ;
|
||||
[OR (CL:WHEN (CHARCODEP F) (* ;
|
||||
"An XCCS code can retrieve its character set")
|
||||
(for D FN (FOCTAL _ (OCTALSTRING (LRSH F 8))) inside
|
||||
UNICODEDIRECTORIES
|
||||
when (SETQ FN (FILDIR (PACKFILENAME 'DIRECTORY D
|
||||
'BODY
|
||||
(CONCAT 'XCCS- FOCTAL
|
||||
'=*)
|
||||
'EXTENSION
|
||||
'TXT
|
||||
'VERSION "")))
|
||||
do (RETURN FN)))
|
||||
(MKLIST (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT
|
||||
'VERSION "")
|
||||
T UNICODEDIRECTORIES))
|
||||
(for D inside UNICODEDIRECTORIES
|
||||
when [SETQ $$VAL (OR (FILDIR (PACKFILENAME 'NAME
|
||||
(CONCAT "XCCS-*=" F)
|
||||
'EXTENSION
|
||||
'TXT
|
||||
'VERSION "" 'BODY D))
|
||||
(FILDIR (PACKFILENAME 'NAME
|
||||
(CONCAT "XCCS-" F "=*")
|
||||
'EXTENSION
|
||||
'TXT
|
||||
'VERSION "" 'BODY D]
|
||||
do (RETURN $$VAL))
|
||||
(AND (SETQ CSI (ASSOC F XCCS-CHARSETS))
|
||||
(READ-UNICODE-MAPPING-FILENAMES (CDR CSI)))
|
||||
(for D inside UNICODEDIRECTORIES
|
||||
when (DIRECTORYNAMEP (SETQ D (CONCAT D ">" F ">")))
|
||||
join (FILDIR (CONCAT D ">*.TXT;"]
|
||||
:TEST
|
||||
(FUNCTION STRING.EQUAL])
|
||||
(for D FN (FOCTAL ← (OCTALSTRING (LRSH F 8))) inside UNICODEDIRECTORIES
|
||||
when (SETQ FN (DIRECTORY (PACKFILENAME 'DIRECTORY D 'BODY (CONCAT 'XCCS-
|
||||
FOCTAL
|
||||
'=*)
|
||||
'EXTENSION
|
||||
'TXT
|
||||
'VERSION ""))) do (RETURN FN)))
|
||||
(MKLIST (FINDFILE (PACKFILENAME 'BODY F 'EXTENSION 'TXT 'VERSION "")
|
||||
T UNICODEDIRECTORIES))
|
||||
(for D inside UNICODEDIRECTORIES
|
||||
when [SETQ $$VAL (OR (DIRECTORY (PACKFILENAME 'NAME (CONCAT "XCCS-*=" F)
|
||||
'EXTENSION
|
||||
'TXT
|
||||
'VERSION "" 'BODY D))
|
||||
(DIRECTORY (PACKFILENAME 'NAME (CONCAT "XCCS-" F "=*")
|
||||
'EXTENSION
|
||||
'TXT
|
||||
'VERSION "" 'BODY D]
|
||||
do (RETURN $$VAL))
|
||||
(AND (SETQ CSI (ASSOC F XCCS-CHARSETS))
|
||||
(READ-UNICODE-MAPPING-FILENAMES (CDR CSI)))
|
||||
(for D inside UNICODEDIRECTORIES when (DIRECTORYNAMEP (SETQ D
|
||||
(CONCAT D ">" F ">")))
|
||||
join (DIRECTORY (CONCAT D ">*.TXT;"]
|
||||
finally (* ;
|
||||
"CL:REMOVE-DUPLICATES doesn't exist in MAKEINIT")
|
||||
(RETURN (for FTAIL on $$VAL unless (thereis FF in (CDR FTAIL)
|
||||
suchthat (STRING-EQUAL (CAR FTAIL)
|
||||
FF)) collect (CAR FTAIL])
|
||||
|
||||
(READ-UNICODE-MAPPING
|
||||
[LAMBDA (FILESPEC PRINT NOERROR) (* ; "Edited 16-Oct-2025 11:25 by rmk")
|
||||
@@ -179,7 +189,7 @@
|
||||
(* ;; "")
|
||||
|
||||
(RESETLST
|
||||
(for FILE STREAM [SEPBITTABLE _ (MAKEBITTABLE (CHARCODE (TAB SPACE] in (
|
||||
(for FILE STREAM [SEPBITTABLE ← (MAKEBITTABLE (CHARCODE (TAB SPACE] in (
|
||||
READ-UNICODE-MAPPING-FILENAMES
|
||||
FILESPEC)
|
||||
join
|
||||
@@ -221,7 +231,8 @@
|
||||
(DEFINEQ
|
||||
|
||||
(MAKE-UNICODE-TRANSLATION-TABLES
|
||||
[LAMBDA (MAPPING REINSTALL) (* ; "Edited 11-Oct-2025 11:54 by rmk")
|
||||
[LAMBDA (MAPPING REINSTALL) (* ; "Edited 21-Feb-2026 22:42 by rmk")
|
||||
(* ; "Edited 11-Oct-2025 11:54 by rmk")
|
||||
(* ; "Edited 4-Sep-2025 00:30 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 15:47 by rmk")
|
||||
(* ; "Edited 31-Jan-2025 17:46 by rmk")
|
||||
@@ -232,26 +243,13 @@
|
||||
(* ; "Edited 3-Feb-2024 00:24 by rmk")
|
||||
(* ; "Edited 30-Jan-2024 09:54 by rmk")
|
||||
(* ; "Edited 21-Aug-2021 13:12 by rmk:")
|
||||
(SETQ MAPPING (GET-MCCS-UNICODE-MAPPING MAPPING))
|
||||
|
||||
(* ;; "MAPPING is the list of numeric code correspondence pairs constructed by applying READ-UNICODE-MAPPING to XCCS-to-Unicode mapping files. This applies the XCCS-to-MCCS translations, and then updates or produces two recoding arrays, one maps left-side codes into right-side codes (e.g. MCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. MCCS).")
|
||||
(* ; "Edited 17-Aug-2020 08:46 by rmk:")
|
||||
(CL:UNLESS [AND (LISTP MAPPING)
|
||||
(FOR PAIR R IN MAPPING AS I TO 10
|
||||
ALWAYS (AND (LISTP PAIR)
|
||||
(CHARCODEP (CAR PAIR))
|
||||
[FIXP (SETQ R (CAR (MKLIST (CADR PAIR]
|
||||
(CHARCODEP (IABS R]
|
||||
|
||||
(* ;; "Seems like the argument is not already a list of mapping pairs (perhaps with a combiner), presumably a list of charsets to be read.")
|
||||
|
||||
(SETQ MAPPING (READ-UNICODE-MAPPING MAPPING)))
|
||||
(SETQ MAPPING (XCCSTOMCCS-MAPPING MAPPING))
|
||||
|
||||
(* ;; "This updates or produces two recoding arrays, one maps left-side codes into right-side codes (e.g. XCCS or ISO8859-1 to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. XCCS).")
|
||||
(* ;; "This updates or produces two recoding arrays, one maps left-side codes into right-side codes (e.g. MCCS to Unicode), for printing, the other maps right-side (Unicode) codes to corresponding right-side codes (e.g. MCCS).")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "If REINSTALL is T, the new mapping vectors replace the current maps in the *XCCSTOUNICODE* and *UNICODETOXCCS* global variables. Otherwise we create new tables (mostly for comparison and debugging).")
|
||||
(* ;; "If REINSTALL is T, the new mapping vectors replace the current maps in the *MCCSTOUNICODE* and *UNICODETOMCCS* global variables. Otherwise we create new tables (mostly for comparison and debugging).")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
@@ -270,6 +268,55 @@
|
||||
(SETQ *NEXT-PRIVATE-UNICODE* FIRST-PRIVATE-UNICODE))
|
||||
(MERGE-UNICODE-TRANSLATION-TABLES NIL MAPPING])
|
||||
|
||||
(GET-MCCS-UNICODE-MAPPING
|
||||
[LAMBDA (MAPPING) (* ; "Edited 22-Feb-2026 00:29 by rmk")
|
||||
|
||||
(* ;; "MAPPING is the list of numeric code correspondence pairs mapping MCCS-to-Unicode, or a specification of XCCS-to-Unicode files to be read and converted to MCCS-to-UNICODE.")
|
||||
|
||||
(SORT (if [AND (LISTP MAPPING)
|
||||
(for PAIR R in MAPPING as I to 10
|
||||
always (AND (LISTP PAIR)
|
||||
(CHARCODEP (CAR PAIR))
|
||||
[FIXP (SETQ R (CAR (MKLIST (CADR PAIR]
|
||||
(CHARCODEP (IABS R]
|
||||
then
|
||||
(* ;; "The argument is already a list of MCCS-to-UNICODE mapping pairs")
|
||||
|
||||
MAPPING
|
||||
else
|
||||
(* ;; "Mapping files are is read as XCCS-UNICODE, make it MCCS")
|
||||
|
||||
(XCCSTOMCCS-MAPPING (READ-UNICODE-MAPPING MAPPING)))
|
||||
T])
|
||||
|
||||
(INVERT-UNICODE-MAPPING
|
||||
[LAMBDA (MAPPING) (* ; "Edited 22-Feb-2026 00:39 by rmk")
|
||||
|
||||
(* ;; "MAPPING is a list of pairs that map domain codes to range codes (presumably MCCS to UNICODE). This produces an inverted list of pairs that map the range into the domain (Unicode to MCCS) ")
|
||||
|
||||
(LET (INVERTED)
|
||||
(SETQ INVERTED (SORT (for P D R OLDR in MAPPING eachtime (SETQ D (CAR P))
|
||||
(SETQ R (CADR P))
|
||||
|
||||
(* ;;
|
||||
"We don't do combiners, but we are allowing non-SMALLP's")
|
||||
unless (OR (LISTP D)
|
||||
(LISTP R)) collect (LIST R D))
|
||||
T))
|
||||
|
||||
(* ;; "If MAPPING contains two pairs that map to the same U (e.g. (M1 U) and (M2 U)), we want the inverse table to collect them into a single pair (U M1 M2) instead of two pairs (U M1) (U M2), with the lowest M code first. Those pairs represent alternative inverse mappings. There are no duplicates/alternative table entries in the M-to-U direction.")
|
||||
|
||||
(* ;; "The SORT above means that multiple inverted pairs for the same U will be next to each other in the list.")
|
||||
|
||||
[for PTAIL PTAIL2 U MS on INVERTED eachtime (SETQ U (CAAR PTAIL))
|
||||
when (SETQ MS (for old PTAIL2 P2 on PTAIL eachtime (SETQ P2 (CADR PTAIL2))
|
||||
while (EQ U (CAR P2)) collect (CADR P2)))
|
||||
do (RPLACD PTAIL (CDR PTAIL2))
|
||||
(RPLACD (CAR PTAIL)
|
||||
(SORT (CONS (CADR (CAR PTAIL))
|
||||
MS]
|
||||
INVERTED])
|
||||
|
||||
(XCCSTOMCCS-MAPPING
|
||||
[LAMBDA (XTOUMAPPING) (* ; "Edited 11-Oct-2025 12:57 by rmk")
|
||||
|
||||
@@ -292,152 +339,12 @@
|
||||
XTOMCODES)))
|
||||
finally (push XTOUMAPPING (CHARCODE (DEL DEL)))
|
||||
(RETURN XTOUMAPPING])
|
||||
|
||||
(MERGE-UNICODE-TRANSLATION-TABLES
|
||||
[LAMBDA (INVERSE MAPPING TABLE INVERSETABLE) (* ; "Edited 11-Oct-2025 10:24 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 15:28 by rmk")
|
||||
(* ; "Edited 1-Feb-2025 21:42 by rmk")
|
||||
(* ; "Edited 26-Jan-2025 12:58 by rmk")
|
||||
(* ; "Edited 22-Jan-2025 08:20 by rmk")
|
||||
(* ; "Edited 19-Jan-2025 15:58 by rmk")
|
||||
(* ; "Edited 18-Jan-2025 11:49 by rmk")
|
||||
(* ; "Edited 27-Mar-2024 12:10 by rmk")
|
||||
(* ; "Edited 3-Feb-2024 12:46 by rmk")
|
||||
(* ; "Edited 31-Jan-2024 10:06 by rmk")
|
||||
|
||||
(* ;; "MAPPINGS is a list of pairs that map domain codes to range codes. TABLE and INVERSETABLE default to *MCCSTOUNICODE* *UNICODETOMCCS* respectively. ")
|
||||
|
||||
(CL:UNLESS TABLE
|
||||
[SETQ TABLE (OR *MCCSTOUNICODE* (SETQ *MCCSTOUNICODE* (HASHARRAY (LENGTH MAPPING])
|
||||
(CL:UNLESS INVERSETABLE
|
||||
[SETQ INVERSETABLE (OR *UNICODETOMCCS* (SETQ *UNICODETOMCCS* (HASHARRAY (LENGTH MAPPING])
|
||||
(for M D R OLDR in MAPPING first (CL:IF INVERSE (swap TABLE INVERSETABLE))
|
||||
eachtime (SETQ D (CAR M))
|
||||
(SETQ R (CADR M))
|
||||
|
||||
(* ;; "We don't do combiners, but we are allowing non-SMALLP's")
|
||||
unless (OR (LISTP D)
|
||||
(LISTP R)) do
|
||||
(* ;; "The (CONS R OLDR) deals with alternatives: (U X1) (U X2) => (U (X1 X2)), lowest code first. Those are only possible in the U-to-X direction when the tables contain (X1 U) and (X2 U). There are no duplicates/alternative table entries in the X-to-U direction.")
|
||||
|
||||
(SETQ OLDR (GETHASH D TABLE))
|
||||
(CL:UNLESS (MEMB R OLDR)
|
||||
(PUTHASH D (SORT (CONS R OLDR))
|
||||
TABLE))
|
||||
(swap D R)
|
||||
(SETQ OLDR (GETHASH D INVERSETABLE))
|
||||
(CL:UNLESS (MEMB R OLDR)
|
||||
(PUTHASH D (SORT (CONS R OLDR))
|
||||
INVERSETABLE)))
|
||||
(LIST TABLE INVERSETABLE])
|
||||
|
||||
(UNICODE.UNMAPPED
|
||||
[LAMBDA (CODE TABLE DONTFAKE) (* ; "Edited 24-Apr-2025 15:48 by rmk")
|
||||
(* ; "Edited 22-Jan-2025 08:19 by rmk")
|
||||
(* ; "Edited 19-Jan-2025 22:02 by rmk")
|
||||
(* ; "Edited 18-Jan-2025 12:02 by rmk")
|
||||
(* ; "Edited 2-Feb-2024 23:52 by rmk")
|
||||
(* ; "Edited 31-Jan-2024 10:07 by rmk")
|
||||
(* ; "Edited 11-Aug-2020 20:23 by rmk:")
|
||||
|
||||
(* ;; "This is the slow fall-out when UNICODE.TRANSLATE determines that CODE has no fast mapping in TRANSLATION-TABLE.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(* ;; "If we have not already installed the mapping segment for that code, we try to retrieve it from the numberic file. If that segment mapping doesn't exist or doesn't have an entry for CODE, we fake up a mapping with a negative range in both directions. One way or the other, there will be an entry for that segment in both mapping vectors.")
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(PROG ((INVERSE (EQ TABLE *UNICODETOMCCS*))
|
||||
RANGE HASH)
|
||||
|
||||
(* ;; "If we already looked up CODE's character set in a file, then we have already filled in its information in the translation table. If it didn't have a code for a particular character, then we fake it here. Faked codes are negative, so we can detect them easily, and interpret them with IABS.")
|
||||
|
||||
(CL:WHEN (AND (UNICODE-EXTEND-TRANSLATION? CODE TABLE)
|
||||
(SETQ RANGE (GETHASH CODE TABLE)))
|
||||
|
||||
(* ;; "We might have gotten the segment that didn't have an entry for CODE.")
|
||||
|
||||
(RETURN RANGE))
|
||||
|
||||
(* ;; "")
|
||||
|
||||
(CL:UNLESS DONTFAKE
|
||||
|
||||
(* ;; "Our attempt at extending the known tables did not provide a mapping for CODE. So we fake it up with the next unused private code in the code space. ")
|
||||
|
||||
(* ;; "The number of possible faked mappings is determined by the number of private-use Unicodes, since the MCCS character space is pretty sparse. The codes don't have to come from the same part of the code space, and the NEXTCODEs are saved in global variables. The last available codes are constants.")
|
||||
|
||||
(CL:WHEN (IEQP *NEXT-PRIVATE-MCCSCODE* LAST-PRIVATE-MCCSCODE)
|
||||
(* ;
|
||||
"Same number of available codes both ways")
|
||||
(ERROR "EXHAUSTED RANGE FOR UNMAPPED CODES"))
|
||||
(if INVERSE
|
||||
then (SETQ RANGE *NEXT-PRIVATE-MCCSCODE*)
|
||||
(add *NEXT-PRIVATE-MCCSCODE* 1)
|
||||
else (SETQ RANGE *NEXT-PRIVATE-UNICODE*)
|
||||
(add *NEXT-PRIVATE-UNICODE* 1))
|
||||
(MERGE-UNICODE-TRANSLATION-TABLES INVERSE (CONS (LIST CODE RANGE)))
|
||||
|
||||
(* ;; "CONS because of LIST convention so we can eventually distinguish combiners.")
|
||||
|
||||
(RETURN (CONS RANGE)))])
|
||||
|
||||
(UNICODE-EXTEND-TRANSLATION?
|
||||
[LAMBDA (CODE TABLE) (* ; "Edited 11-Oct-2025 09:49 by rmk")
|
||||
(* ; "Edited 4-Sep-2025 00:34 by rmk")
|
||||
(* ; "Edited 29-Jun-2025 16:44 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 15:49 by rmk")
|
||||
(* ; "Edited 26-Jan-2025 11:26 by rmk")
|
||||
(* ; "Edited 21-Jan-2025 22:31 by rmk")
|
||||
(* ; "Edited 18-Jan-2025 12:40 by rmk")
|
||||
(* ; "Edited 13-Jan-2025 23:50 by rmk")
|
||||
(* ; "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")
|
||||
|
||||
(* ;; "There is currently no mapping for CODE in TABLE, hopefully just because the relevant character-set mapping has not been installed. We infer from TABLE whether CODE is an MCCS or UNICODE code and look for the proper mapping table (forward or inverted) for its character set. ")
|
||||
|
||||
(* ;; "We record which character sets we have already expanded so we don't do them again.")
|
||||
|
||||
(LET ((CHARSET (\CHARSET CODE))
|
||||
(INVERSE (EQ TABLE *UNICODETOMCCS*))
|
||||
MAPPING FILE)
|
||||
|
||||
(* ;; "If we already looked for CHARSET in the file and found anything, it has already been merged. Otherwise, it would just fail again")
|
||||
|
||||
(CL:UNLESS (MEMB CHARSET (CL:IF INVERSE
|
||||
*UNICODE-LOADED-CHARSETS*
|
||||
*MCCS-LOADED-CHARSETS*))
|
||||
|
||||
(* ;; "Don't try this charset again.")
|
||||
|
||||
(CL:IF INVERSE
|
||||
(push *UNICODE-LOADED-CHARSETS* CHARSET)
|
||||
(push *MCCS-LOADED-CHARSETS* CHARSET))
|
||||
(SETQ FILE (FINDFILE (CL:IF INVERSE
|
||||
'UNICODE-TO-MCCS-MAPPINGS
|
||||
'MCCS-TO-UNICODE-MAPPINGS)
|
||||
T UNICODEDIRECTORIES))
|
||||
|
||||
(* ;; "The mappings files are indexed by CHARSET.")
|
||||
|
||||
(CL:WHEN [AND FILE (SETQ MAPPING (CL:WITH-OPEN-FILE (STREAM FILE :INPUT)
|
||||
(CL:WHEN (FILEPOS (CONCAT "[" CHARSET " ")
|
||||
STREAM NIL NIL NIL T)
|
||||
(READ STREAM]
|
||||
|
||||
(* ;;
|
||||
"Merge MAPPING into both tables, respecting the direction indicated by TABLE. ")
|
||||
|
||||
(MERGE-UNICODE-TRANSLATION-TABLES INVERSE MAPPING)
|
||||
T))])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(ALL-UNICODE-MAPPINGS
|
||||
[LAMBDA (INVERTED FILE) (* ; "Edited 24-Apr-2025 15:51 by rmk")
|
||||
[LAMBDA (INVERTED FILE) (* ; "Edited 22-Feb-2026 10:42 by rmk")
|
||||
(* ; "Edited 24-Apr-2025 15:51 by rmk")
|
||||
(* ; "Edited 31-Jan-2025 17:46 by rmk")
|
||||
(* ; "Edited 26-Jan-2025 13:40 by rmk")
|
||||
(* ; "Edited 22-Jan-2025 14:07 by rmk")
|
||||
@@ -453,38 +360,32 @@
|
||||
(* ;; "The first index level segments all the domain codes according to their character sets. The segments are sorted by character set, the pairs within each segment are sorted by their domain codes. ")
|
||||
|
||||
(* ;;
|
||||
"E.g. if INVERTED=NIL and given a XCCS code, the lookup for the corresponding Unicode(s) is")
|
||||
"E.g. if INVERTED=NIL and given a MCCS code, the lookup for the corresponding Unicode(s) is")
|
||||
|
||||
(* ;; " (CADR (ASSOC MCCSCODE (\CHARSET MCCSCODE) INDEX)))).")
|
||||
(* ;; " (CAR (GETMULTI INDEX (\CHARSET MCCSCODE) MCCSCODE).")
|
||||
|
||||
(* ;; "If FILE is not NIL, the result is written to a file. If FILE is T, the file is either MCCS-TO-UNICODE-MAPPINGS.TXT or UNICODE-TO-MCCS-MAPPINGS.TXT, depending on INVERTED.")
|
||||
|
||||
(LET (INDEX)
|
||||
(for PAIR DOMAIN RANGE CHARSET in (READ-UNICODE-MAPPING 'ALL) eachtime (SETQ DOMAIN
|
||||
(CAR PAIR))
|
||||
(SETQ RANGE (CADR PAIR))
|
||||
|
||||
(* ;;
|
||||
"(LISTP RANGE) is a combiner, ignored for now.")
|
||||
unless (LISTP RANGE) do (CL:WHEN INVERTED (SWAP DOMAIN RANGE))
|
||||
(LET [INDEX (MAPPING (GET-MCCS-UNICODE-MAPPING 'ALL]
|
||||
(for PAIR in (CL:IF INVERTED
|
||||
(INVERT-UNICODE-MAPPING MAPPING)
|
||||
MAPPING) unless (LISTP (CADR PAIR)) do
|
||||
(* ;;
|
||||
"(LISTP (CADR PAIR) is a combiner, ignored for now.")
|
||||
|
||||
(* ;;
|
||||
(* ;;
|
||||
"One segment for each high-byte character set. This aligns with UNICODE-EXTEND.TRANSLATION?")
|
||||
|
||||
[SETQ CHARSET (OR (ASSOC (\CHARSET DOMAIN)
|
||||
INDEX)
|
||||
(CAR (push INDEX (CONS (\CHARSET DOMAIN]
|
||||
(* ;; "For alternative mappings (in the U-to-M direction) we end up with (D R1 R2 ...). (CAR (GETMULTI)) is the first (and almost always) the only one.")
|
||||
|
||||
(* ;; "For alternative mappings (in the U-to-M direction) we end up with (D R1 R2 ...). (CADR is the first (and almost always) the only one.")
|
||||
|
||||
(pushnew [CDR (OR (ASSOC DOMAIN (CDR CHARSET))
|
||||
(CAR (push (CDR CHARSET)
|
||||
(CONS DOMAIN]
|
||||
RANGE))
|
||||
(PUSHMULTI-NEW INDEX
|
||||
(\CHARSET (CAR PAIR))
|
||||
(CAR PAIR)
|
||||
(CADR PAIR)))
|
||||
|
||||
(* ;; "Push the charset mappings down an extra CONS, so that a subsequent READ will get them all after a FILEPOS search for super-paren [")
|
||||
|
||||
[for CS in INDEX do (for M in (CDR CS) when (CDDR M) do
|
||||
(for CS in INDEX do (for M in (CDR CS) when (CDDR M) do
|
||||
(* ;;
|
||||
"Sort the range alternatives, if any")
|
||||
|
||||
@@ -494,7 +395,7 @@
|
||||
(* ;; "Sort by domain codes and push down a level")
|
||||
|
||||
(change (CDR CS)
|
||||
(CONS (SORT DATUM T]
|
||||
(SORT DATUM T)))
|
||||
(SETQ INDEX (SORT INDEX T)) (* ; "Sort character sets")
|
||||
(if FILE
|
||||
then (SETQ FILE (PACKFILENAME 'BODY (if (NEQ FILE T)
|
||||
@@ -544,18 +445,347 @@
|
||||
(FULLNAME STREAM))))])
|
||||
)
|
||||
|
||||
(RPAQ? *MCCSTOUNICODE* )
|
||||
|
||||
(RPAQ? *UNICODETOMCCS* )
|
||||
|
||||
(RPAQ? *MCCS-LOADED-CHARSETS* )
|
||||
(* ; "Write Unicode mapping files")
|
||||
|
||||
(RPAQ? *UNICODE-LOADED-CHARSETS* )
|
||||
(DEFINEQ
|
||||
|
||||
(RPAQ? *LARGEUNICODES* )
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
(WRITE-UNICODE-MAPPING
|
||||
[LAMBDA (MAPPING INCLUDECHARSETS FILE EMPTYOK) (* ; "Edited 4-Jan-2024 22:44 by rmk")
|
||||
(* ; "Edited 16-Aug-2020 16:56 by rmk:")
|
||||
|
||||
(MAKE-UNICODE-TRANSLATION-TABLES 'ALL)
|
||||
(* ;; "Writes a symbol unicode mapping file. Mapping is a list of (XCCS-code Unicode) pairs, which may contain codes in multiple character sets.")
|
||||
|
||||
(* ;; "If FILE is NIL, it defaults to a name XCCS- followed by the octal character sets in the mapping, in the unicode/XEROX directory.")
|
||||
|
||||
(* ;; "The output lines are of the form x0XXX<tab>x0UUUU<tab># Unicode-char")
|
||||
|
||||
(* ;;
|
||||
"If INCLUDECHARSETS=T then the mappings are split up into separate per-character set files.")
|
||||
|
||||
(* ;; "Otherwise, all and only mappings included in thos charsets are included in a single output file--an implicit subset.")
|
||||
|
||||
(IF (AND (EQ INCLUDECHARSETS T)
|
||||
(NULL FILE))
|
||||
THEN (IF MAPPING
|
||||
THEN (FOR CSI F IN XCCS-SET-NAMES WHEN (SETQ F (WRITE-UNICODE-MAPPING MAPPING
|
||||
(CAR CSI)
|
||||
NIL T)) COLLECT F)
|
||||
ELSE (PRINTOUT T "THERE ARE NO MAPPINGS" T)
|
||||
NIL)
|
||||
ELSE
|
||||
(LET
|
||||
(IMAPPING CSETINFO RANGES)
|
||||
(CL:MULTIPLE-VALUE-SETQ (IMAPPING CSETINFO RANGES)
|
||||
(WRITE-UNICODE-INCLUDED MAPPING INCLUDECHARSETS))
|
||||
(IF IMAPPING
|
||||
THEN (CL:WITH-OPEN-FILE
|
||||
(STREAM (WRITE-UNICODE-MAPPING-FILENAME FILE CSETINFO RANGES)
|
||||
:DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION :EXTERNAL-FORMAT :UTF-8-RAW)
|
||||
(WRITE-UNICODE-MAPPING-HEADER STREAM CSETINFO RANGES)
|
||||
(SORT IMAPPING T)
|
||||
(FOR M CSET LEFTC FIRSTRIGHTC CSI IN IMAPPING
|
||||
DO (SETQ LEFTC (CAR M))
|
||||
(SETQ FIRSTRIGHTC (CADR M))
|
||||
(CL:UNLESS (EQ CSET (LRSH LEFTC 8))
|
||||
(SETQ CSET (LRSH LEFTC 8))
|
||||
(SETQ CSI (ASSOC CSET CSETINFO))
|
||||
(PRINTOUT STREAM T "# " .P2 (CADR CSI)
|
||||
" "
|
||||
(CADDR CSI)
|
||||
T))
|
||||
(PRINTOUT STREAM "0x" (HEXSTRING LEFTC 4)
|
||||
%#
|
||||
(FOR RIGHTC IN (CDR M) DO (PRINTOUT NIL " " "0x" (HEXSTRING RIGHTC 4)))
|
||||
" # "
|
||||
(SELECTC FIRSTRIGHTC
|
||||
(UNDEFINEDCODE
|
||||
(* ;; "FFFF")
|
||||
|
||||
"UNDEFINED")
|
||||
(MISSINGCODE
|
||||
(* ;; "FFFE")
|
||||
|
||||
"MISSING")
|
||||
(IF (ILESSP FIRSTRIGHTC 32)
|
||||
THEN (* ; "Control chars")
|
||||
[CONCAT "↑" (CHARACTER (IPLUS FIRSTRIGHTC (CHARCODE @]
|
||||
ELSE (CHARACTER FIRSTRIGHTC)))
|
||||
T))
|
||||
(FULLNAME STREAM))
|
||||
ELSEIF (NOT EMPTYOK)
|
||||
THEN (PRINTOUT T "THERE ARE NO MAPPINGS")
|
||||
(CL:WHEN INCLUDECHARSETS
|
||||
(PRINTOUT T " FOR " .PPVTL (MKLIST INCLUDECHARSETS)
|
||||
T))
|
||||
NIL])
|
||||
|
||||
(WRITE-UNICODE-INCLUDED
|
||||
[LAMBDA (MAPPING INCLUDECHARSETS) (* ; "Edited 4-Aug-2020 17:47 by rmk:")
|
||||
|
||||
(* ;; "CSETINFO is a list of (num string name) for each included character set.")
|
||||
|
||||
(LET (CHARSETS CSETINFO RANGES ICSETS IMAPPING)
|
||||
|
||||
(* ;; "Normalize the INCLUDECHARSETS, then reduce MAPPING to the included mappings")
|
||||
|
||||
[SETQ ICSETS (FOR C POS KNOWN INSIDE (OR INCLUDECHARSETS (FOR CSI IN XCCS-SET-NAMES
|
||||
COLLECT (CAR CSI)))
|
||||
JOIN [SETQ KNOWN (OR (SASSOC C XCCS-SET-NAMES)
|
||||
(FIND N IN XCCS-SET-NAMES
|
||||
SUCHTHAT (EQ C (CADR N)))
|
||||
(HELP "UNKNOWN CHARACTER SET" (OCTALSTRING C]
|
||||
(IF (SETQ POS (STRPOS "-" (CAR KNOWN)))
|
||||
THEN (FOR I FROM (CL:PARSE-INTEGER (SUBSTRING (CAR KNOWN)
|
||||
1
|
||||
(SUB1 POS))
|
||||
:RADIX 8)
|
||||
TO (CL:PARSE-INTEGER (SUBSTRING (CAR KNOWN)
|
||||
(ADD1 POS))
|
||||
:RADIX 8) COLLECT (LIST I (OCTALSTRING I)
|
||||
(CADR KNOWN)))
|
||||
ELSE (CONS (CONS (CL:PARSE-INTEGER (CAR KNOWN)
|
||||
:RADIX 8)
|
||||
KNOWN]
|
||||
(SETQ IMAPPING (FOR M CSI IN MAPPING WHEN (SETQ CSI (ASSOC (LRSH (CAR M)
|
||||
8)
|
||||
ICSETS))
|
||||
COLLECT
|
||||
|
||||
(* ;; "The attested subset of INCLUDED")
|
||||
|
||||
(CL:UNLESS (MEMB CSI CSETINFO)
|
||||
(PUSH CSETINFO CSI))
|
||||
M))
|
||||
|
||||
(* ;; "Sort as numbers, not octal strings, then group into consecutive ranges")
|
||||
|
||||
(SETQ CSETINFO (SORT CSETINFO T))
|
||||
[SETQ RANGES (FOR CTAIL C START END ON (FOR CSI IN CSETINFO COLLECT (CAR CSI)) WHILE CTAIL
|
||||
COLLECT (SETQ START (CAR CTAIL))
|
||||
(SETQ END START)
|
||||
(CONS START (WHILE [AND (CDR CTAIL)
|
||||
(EQ END (SUB1 (CADR CTAIL]
|
||||
COLLECT (SETQ CTAIL (CDR CTAIL))
|
||||
(SETQ END (CAR CTAIL]
|
||||
|
||||
(* ;; "Split out groups of less than 3. But if a range exhaustively covers a known subset (like JIS), replace by the name")
|
||||
|
||||
[SETQ RANGES (FOR R STR KNOWN LAST IN RANGES
|
||||
JOIN (SETQ LAST (CAR (LAST R)))
|
||||
(IF (EQ (CAR R)
|
||||
LAST)
|
||||
THEN (CONS (OCTALSTRING (CAR R)))
|
||||
ELSEIF (SETQ KNOWN (SASSOC (SETQ STR (CONCAT (OCTALSTRING
|
||||
(CAR R))
|
||||
"-"
|
||||
(OCTALSTRING LAST)))
|
||||
XCCS-SET-NAMES))
|
||||
THEN (CONS (CADR KNOWN))
|
||||
ELSEIF (CDDR R)
|
||||
THEN (CONS STR)
|
||||
ELSE (LIST (OCTALSTRING (CAR R))
|
||||
(OCTALSTRING LAST]
|
||||
(CL:VALUES IMAPPING CSETINFO RANGES])
|
||||
|
||||
(WRITE-UNICODE-MAPPING-HEADER
|
||||
[LAMBDA (STREAM CSETINFO RANGES) (* ; "Edited 5-Jan-2024 13:24 by rmk")
|
||||
(* ; "Edited 4-Aug-2020 17:38 by rmk:")
|
||||
|
||||
(* ;; "Writes the standard per-file header information")
|
||||
|
||||
(FOR LINE IN UNICODE-MAPPING-HEADER
|
||||
DO (PRINTOUT STREAM "#" 2)
|
||||
(SELECTQ LINE
|
||||
(XCCSCHARACTERSETS
|
||||
(PRINTOUT STREAM " XCCS charset")
|
||||
(IF (CDR CSETINFO)
|
||||
THEN (PRINTOUT STREAM "s:" -4)
|
||||
(FOR R IN RANGES DO (PRINTOUT STREAM R " "))
|
||||
ELSE (* ; "Singleton")
|
||||
(PRINTOUT STREAM ": " -4 (CADAR CSETINFO)
|
||||
" "
|
||||
(CADDAR CSETINFO)))
|
||||
(TERPRI STREAM))
|
||||
(DATE (PRINTOUT STREAM " Date:" -13 (DATE (DATEFORMAT NO.TIME NO.LEADING.SPACES)
|
||||
)
|
||||
T))
|
||||
(PRINTOUT STREAM LINE T)))
|
||||
(TERPRI STREAM])
|
||||
|
||||
(WRITE-UNICODE-MAPPING-FILENAME
|
||||
[LAMBDA (FILE CSETINFO RANGES) (* ; "Edited 4-Aug-2020 19:34 by rmk:")
|
||||
(PACKFILENAME 'BODY [OR FILE (CONCATLIST
|
||||
(CONS 'XCCS- (IF (CDR CSETINFO)
|
||||
THEN (FOR RTAIL R ON RANGES
|
||||
JOIN (SETQ R (CAR RTAIL))
|
||||
(SETQ R (CL:IF (LISTP R)
|
||||
(LIST (CAR R)
|
||||
"-"
|
||||
(CDR R))
|
||||
(CONS R)))
|
||||
(CL:IF (CDR RTAIL)
|
||||
(NCONC1 R ","))
|
||||
R)
|
||||
ELSE (LIST (CADAR CSETINFO)
|
||||
"="
|
||||
(CADDAR CSETINFO]
|
||||
'DIRECTORY
|
||||
(CAR UNICODEDIRECTORIES)
|
||||
'EXTENSION
|
||||
'TXT])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(XCCS-UTF8-AFTER-OPEN
|
||||
[LAMBDA (STREAM ACCESS PARAMETERS) (* ; "Edited 3-Jan-2024 10:27 by rmk")
|
||||
(* ; "Edited 13-Aug-2020 11:54 by rmk:")
|
||||
|
||||
(* ;;
|
||||
"If added to STREAM-AFTER-OPEN-FNS, causes mapping files to be opened as UTF-8. For development")
|
||||
|
||||
(CL:WHEN (AND (STRPOS "XCCS-" (U-CASE (FULLNAME STREAM)))
|
||||
[EQ 'TXT (U-CASE (FILENAMEFIELD (FULLNAME STREAM)
|
||||
'EXTENSION]
|
||||
(NOT (ASSOC 'EXTERNALFORMAT PARAMETERS)))
|
||||
(STREAMPROP STREAM 'EXTERNALFORMAT :UTF-8))])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ;; "Automate dumping of a documentation prefix")
|
||||
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(RPAQ MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16))
|
||||
|
||||
(RPAQ UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16))
|
||||
|
||||
|
||||
(CONSTANTS (MISSINGCODE (CL:PARSE-INTEGER "FFFE" :RADIX 16))
|
||||
(UNDEFINEDCODE (CL:PARSE-INTEGER "FFFF" :RADIX 16)))
|
||||
)
|
||||
)
|
||||
|
||||
(RPAQQ UNICODE-MAPPING-HEADER
|
||||
("" " Name: XCCS (Version 2.0) to Unicode" " Unicode version: 3.0"
|
||||
XCCSCHARACTERSETS " Table version: 0.1" " Table format: Format A"
|
||||
DATE " Author: Ron Kaplan <Ron.Kaplan@post.harvard.edu>" ""
|
||||
"This file contains mappings from the Xerox Character Code Standard (version"
|
||||
"2.0, 1990) into Unicode 3.0. standard codes. That is an extension of the"
|
||||
"version of XCCS corresponding to the fonts in the Medley system." ""
|
||||
"The format of this file conforms to the format of the other Unicode-supplied"
|
||||
"mapping files:" " Three white-space (tab or spaces) separated columns:"
|
||||
" Column 1 is the XCCS code (as hex 0xXXXX)"
|
||||
" Column 2 is the corresponding Unicode (as hex 0xXXXX)"
|
||||
" Column 3 (after #) is a comment column. For convenience, it contains the"
|
||||
" Unicode character itself and the Unicode character names when available."
|
||||
"Unicode FFFF is used for undefined XCCS codes (Column 3 = UNDEFINED"
|
||||
"Unicode FFFE is used for XCCS codes that have not yet been filled in."
|
||||
"(Column 3 = MISSING)" "" "This file is encoded in UTF-8, so that the Unicode characters"
|
||||
"are properly displayed in Column 3 and can be edited by standard"
|
||||
"Unicode-enabled editors (e.g. Mac Textedit)." ""
|
||||
"This file can also be read by the function"
|
||||
"READ-UNICODE-MAPPING in the UNICODE Medley library package." ""
|
||||
"The entries are in XCCS order and grouped by character sets. In front of"
|
||||
"the mappings, for convenience, there is a line with the octal XCCS"
|
||||
"character set, after #." ""
|
||||
"Note that a given XCCS code might map to codes in several different Unicode"
|
||||
"positions, since there are repetitions in the Unicode standard." ""
|
||||
"For more details, see the associated README.TXT file." ""
|
||||
"Any comments or problems, contact <ron.kaplan@post.harvard.edu>"))
|
||||
(DEFINEQ
|
||||
|
||||
(UTF8HEXSTRING
|
||||
[LAMBDA (CHARCODE) (* ; "Edited 10-Aug-2020 08:33 by rmk:")
|
||||
|
||||
(* ;; "Utility to produces the UTF8 hexstring representing CODE")
|
||||
|
||||
(HEXSTRING (IF (ILESSP CHARCODE 128)
|
||||
THEN CHARCODE
|
||||
ELSEIF (ILESSP CHARCODE 2048)
|
||||
THEN (* ; "x800")
|
||||
(LOGOR (LLSH (LOGOR (LLSH 3 6)
|
||||
(LRSH CHARCODE 6))
|
||||
8)
|
||||
(LOGOR (LLSH 2 6)
|
||||
(LOADBYTE CHARCODE 0 6)))
|
||||
ELSEIF (ILESSP CHARCODE 65536)
|
||||
THEN (* ; "x10000")
|
||||
(LOGOR (LLSH (LOGOR (LLSH 7 5)
|
||||
(LRSH CHARCODE 12))
|
||||
16)
|
||||
(LLSH (LOGOR (LLSH 2 6)
|
||||
(LOADBYTE CHARCODE 6 6))
|
||||
8)
|
||||
(LOGOR (LLSH 2 6)
|
||||
(LOADBYTE CHARCODE 0 6)))
|
||||
ELSEIF (ILESSP CHARCODE 2097152)
|
||||
THEN (* ; "x200000")
|
||||
(LOGOR (LLSH (LOGOR (LLSH 15 4)
|
||||
(LRSH CHARCODE 18))
|
||||
24)
|
||||
(LLSH (LOGOR (LLSH 2 6)
|
||||
(LOADBYTE CHARCODE 12 6))
|
||||
16)
|
||||
(LLSH (LOGOR (LLSH 2 6)
|
||||
(LOADBYTE CHARCODE 6 6))
|
||||
8)
|
||||
(LOGOR (LLSH 2 6)
|
||||
(LOADBYTE CHARCODE 0 6)))
|
||||
ELSE (ERROR "CHARCODE too big for UTF8" CHARCODE])
|
||||
)
|
||||
|
||||
|
||||
|
||||
(* ; "debugging")
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(SHOWCHARS
|
||||
[LAMBDA (FONT FROMCHAR TOCHAR ONELINE) (* ; "Edited 5-Oct-2025 17:41 by rmk")
|
||||
(* ; "Edited 7-Sep-2025 20:29 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 10:26 by rmk")
|
||||
(* ; "Edited 24-Jul-2025 11:30 by rmk")
|
||||
(* ; "Edited 8-Jun-2025 20:05 by rmk")
|
||||
(* ; "Edited 26-Jan-2024 14:18 by mth")
|
||||
(* ; "Edited 1-Aug-2020 09:27 by rmk:")
|
||||
[SETQ FONT (FONTCREATE (OR FONT '(CLASSIC 12]
|
||||
(RESETLST
|
||||
[LET ((OLDFONT (DSPFONT NIL T))
|
||||
CHARS)
|
||||
(CL:UNLESS (CHARCODEP FROMCHAR)
|
||||
(SETQ FROMCHAR (OR (CHARCODE.DECODE FROMCHAR T)
|
||||
FROMCHAR)))
|
||||
(SETQ CHARS (if (LISTP FROMCHAR)
|
||||
elseif (CHARCODEP FROMCHAR)
|
||||
then (CL:UNLESS (CHARCODEP TOCHAR)
|
||||
(SETQ TOCHAR (OR (CHARCODE.DECODE TOCHAR)
|
||||
FROMCHAR)))
|
||||
(for C from FROMCHAR to TOCHAR collect C)
|
||||
else (CHCON FROMCHAR)))
|
||||
[RESETSAVE OLDFONT '(PROGN (DSPFONT OLDVALUE]
|
||||
(TERPRI)
|
||||
(for C in CHARS do (PRINTOUT T .FONT OLDFONT (CONCAT (OCTALSTRING (\CHARSET C))
|
||||
","
|
||||
(OCTALSTRING (\CHAR8CODE C)))
|
||||
10 .FONT FONT (CHARACTER C))
|
||||
(CL:UNLESS ONELINE (PRINTOUT T T])
|
||||
(TERPRI])
|
||||
)
|
||||
(DECLARE%: DOEVAL@LOAD DONTCOPY
|
||||
(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS HEXCHAR MACRO ((CODE)
|
||||
(HEXSTRING CODE)))
|
||||
|
||||
(PUTPROPS OCTALCHAR MACRO [(CODE)
|
||||
(CONCAT (OCTALSTRING (\CHARSET CODE))
|
||||
","
|
||||
(OCTALSTRING (LOGAND CODE 255])
|
||||
)
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
@@ -563,9 +793,12 @@
|
||||
UNICODE-EXPORTS)
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (3341 12542 (READ-UNICODE-MAPPING-FILENAMES 3351 . 8301) (READ-UNICODE-MAPPING 8303 .
|
||||
12540)) (12609 26839 (MAKE-UNICODE-TRANSLATION-TABLES 12619 . 16379) (XCCSTOMCCS-MAPPING 16381 . 17598
|
||||
) (MERGE-UNICODE-TRANSLATION-TABLES 17600 . 20253) (UNICODE.UNMAPPED 20255 . 23579) (
|
||||
UNICODE-EXTEND-TRANSLATION? 23581 . 26837)) (26840 33676 (ALL-UNICODE-MAPPINGS 26850 . 32339) (
|
||||
XCCSJAPANESECHARSETS 32341 . 33674)))))
|
||||
(FILEMAP (NIL (4107 12829 (READ-UNICODE-MAPPING-FILENAMES 4117 . 8586) (READ-UNICODE-MAPPING 8588 .
|
||||
12827)) (12896 19704 (MAKE-UNICODE-TRANSLATION-TABLES 12906 . 15666) (GET-MCCS-UNICODE-MAPPING 15668
|
||||
. 16688) (INVERT-UNICODE-MAPPING 16690 . 18483) (XCCSTOMCCS-MAPPING 18485 . 19702)) (19705 26328 (
|
||||
ALL-UNICODE-MAPPINGS 19715 . 24991) (XCCSJAPANESECHARSETS 24993 . 26326)) (26373 37135 (
|
||||
WRITE-UNICODE-MAPPING 26383 . 30127) (WRITE-UNICODE-INCLUDED 30129 . 34441) (
|
||||
WRITE-UNICODE-MAPPING-HEADER 34443 . 35691) (WRITE-UNICODE-MAPPING-FILENAME 35693 . 37133)) (37136
|
||||
37812 (XCCS-UTF8-AFTER-OPEN 37146 . 37810)) (40337 42426 (UTF8HEXSTRING 40347 . 42424)) (42453 44495 (
|
||||
SHOWCHARS 42463 . 44493)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
Binary file not shown.
File diff suppressed because it is too large
Load Diff
Binary file not shown.
@@ -1,13 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
|
||||
|
||||
(FILECREATED " 4-Feb-2026 16:02:02" {WMEDLEY}<library>TEDIT>TEDIT.;852 146779
|
||||
(FILECREATED " 2-Mar-2026 18:32:06" {WMEDLEY}<library>tedit>TEDIT.;853 146506
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS TEDIT.MAP.OBJECTS TEDIT.PARAGRAPH.BOUNDARIES)
|
||||
(VARS TEDITCOMS)
|
||||
:CHANGES-TO (VARS TEDITCOMS)
|
||||
|
||||
:PREVIOUS-DATE "31-Jan-2026 11:49:19" {WMEDLEY}<library>TEDIT>TEDIT.;849)
|
||||
:PREVIOUS-DATE " 4-Feb-2026 16:02:02" {WMEDLEY}<library>tedit>TEDIT.;852)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT TEDITCOMS)
|
||||
@@ -29,9 +28,7 @@
|
||||
|
||||
(EXPORT (FILES (FROM LOADUPS)
|
||||
EXPORTS.ALL)))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES TEDIT-EXPORTS.ALL))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES (LOADCOMP)
|
||||
UNICODE)))
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY (FILES TEDIT-EXPORTS.ALL)))
|
||||
[DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
(* ;; "Assertions go to comments if not being checked, so we see value-warnings")
|
||||
@@ -158,11 +155,6 @@
|
||||
(FILESLOAD TEDIT-EXPORTS.ALL)
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
|
||||
(FILESLOAD (LOADCOMP)
|
||||
UNICODE)
|
||||
)
|
||||
(DECLARE%: EVAL@COMPILE DONTCOPY
|
||||
(* "FOLLOWING DEFINITIONS EXPORTED")(DECLARE%: EVAL@COMPILE
|
||||
|
||||
(PUTPROPS TEDIT-ASSERT MACRO [ARGS (COND
|
||||
@@ -2353,27 +2345,27 @@
|
||||
|
||||
(DEFAULT.IMAGETYPE.CONVERSIONS '(TEDIT TEDIT.TO.IMAGEFILE))
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4936 7330 (MAKE-TEDIT-EXPORTS.ALL 4946 . 5492) (UPDATE-TEDIT 5494 . 6423) (EDIT-TEDIT
|
||||
6425 . 7328)) (8760 37759 (TEDIT 8770 . 11384) (TEXTSTREAM 11386 . 13275) (TEXTSTREAMP 13277 . 13661)
|
||||
(COERCETEXTSTREAM 13663 . 17874) (TEDIT.CONCAT 17876 . 21178) (TEDITSTRING 21180 . 22094) (TEDIT-SEE
|
||||
22096 . 22780) (TEDIT.COPY 22782 . 24927) (TEDIT.DELETE 24929 . 26290) (TEDIT.INSERT 26292 . 29261) (
|
||||
TEDIT.TERPRI 29263 . 30377) (TEDIT.KILL 30379 . 31361) (TEDIT.QUIT 31363 . 32729) (TEDIT.MOVE 32731 .
|
||||
33619) (TEDIT.STRINGWIDTH 33621 . 34292) (TEDIT.CHARWIDTH 34294 . 36536) (TEDIT.PARAGRAPH.BOUNDARIES
|
||||
36538 . 37757)) (37760 39701 (TEXTOBJ 37770 . 38235) (COERCETEXTOBJ 38237 . 39699)) (41101 42751 (
|
||||
TDRIBBLE 41111 . 42749)) (42792 54772 (TEDIT.INSERT.OBJECT 42802 . 46509) (TEDIT.EDIT.OBJECT 46511 .
|
||||
49451) (TEDIT.OBJECT.CHANGED 49453 . 52643) (TEDIT.MAP.OBJECTS 52645 . 54300) (\TEDIT.FIRST.OBJPIECE
|
||||
54302 . 54535) (\TEDIT.NEXT.OBJPIECE 54537 . 54770)) (54795 62238 (\TEDIT.CONCAT.PAGEFRAMES 54805 .
|
||||
59872) (\TEDIT.GET.PAGE.HEADINGS 59874 . 60903) (\TEDIT.CONCAT.INSTALL.HEADINGS 60905 . 62236)) (62239
|
||||
65846 (\TEDIT.MOVE.MSG 62249 . 64330) (\TEDIT.READONLY 64332 . 65844)) (65847 71738 (TEDIT.NCHARS
|
||||
65857 . 66230) (TEDIT.RPLCHARCODE 66232 . 69222) (TEDIT.NTHCHARCODE 69224 . 71267) (TEDIT.NTHCHAR
|
||||
71269 . 71736)) (71784 128828 (\TEDIT1 71794 . 73871) (\TEDIT.INSERT 73873 . 79986) (\TEDIT.MOVE 79988
|
||||
. 88086) (\TEDIT.COPY 88088 . 92694) (\TEDIT.REPLACE.SELPIECES 92696 . 97232) (
|
||||
\TEDIT.INSERT.SELPIECES 97234 . 100231) (\TEDIT.RESTARTFN 100233 . 102738) (\TEDIT.CHARDELETE 102740
|
||||
. 105669) (\TEDIT.COPYPIECE 105671 . 110833) (\TEDIT.APPLY.OBJFN 110835 . 113921) (\TEDIT.DELETE
|
||||
113923 . 118291) (\TEDIT.DIFFUSE.PARALOOKS 118293 . 120564) (\TEDIT.WORDDELETE 120566 . 122181) (
|
||||
\TEDIT.WORDDELETE.FORWARD 122183 . 123972) (\TEDIT.FINISHEDIT? 123974 . 128826)) (128829 129488 (
|
||||
\TEDIT.THELP 128839 . 129486)) (129522 138653 (\TEDIT.PARAPIECES 129532 . 131506) (\TEDIT.PARACHNOS
|
||||
131508 . 132400) (\TEDIT.PARA.FIRST 132402 . 135503) (\TEDIT.PARA.LAST 135505 . 138651)) (138654
|
||||
145749 (\TEDIT.WORD.FIRST 138664 . 142668) (\TEDIT.WORD.LAST 142670 . 145747)) (145950 146227 (
|
||||
TEDITSYSTEMDATE 145960 . 146225)) (146363 146570 (TEDIT.IMAGESOURCEP 146373 . 146568)))))
|
||||
(FILEMAP (NIL (4738 7132 (MAKE-TEDIT-EXPORTS.ALL 4748 . 5294) (UPDATE-TEDIT 5296 . 6225) (EDIT-TEDIT
|
||||
6227 . 7130)) (8487 37486 (TEDIT 8497 . 11111) (TEXTSTREAM 11113 . 13002) (TEXTSTREAMP 13004 . 13388)
|
||||
(COERCETEXTSTREAM 13390 . 17601) (TEDIT.CONCAT 17603 . 20905) (TEDITSTRING 20907 . 21821) (TEDIT-SEE
|
||||
21823 . 22507) (TEDIT.COPY 22509 . 24654) (TEDIT.DELETE 24656 . 26017) (TEDIT.INSERT 26019 . 28988) (
|
||||
TEDIT.TERPRI 28990 . 30104) (TEDIT.KILL 30106 . 31088) (TEDIT.QUIT 31090 . 32456) (TEDIT.MOVE 32458 .
|
||||
33346) (TEDIT.STRINGWIDTH 33348 . 34019) (TEDIT.CHARWIDTH 34021 . 36263) (TEDIT.PARAGRAPH.BOUNDARIES
|
||||
36265 . 37484)) (37487 39428 (TEXTOBJ 37497 . 37962) (COERCETEXTOBJ 37964 . 39426)) (40828 42478 (
|
||||
TDRIBBLE 40838 . 42476)) (42519 54499 (TEDIT.INSERT.OBJECT 42529 . 46236) (TEDIT.EDIT.OBJECT 46238 .
|
||||
49178) (TEDIT.OBJECT.CHANGED 49180 . 52370) (TEDIT.MAP.OBJECTS 52372 . 54027) (\TEDIT.FIRST.OBJPIECE
|
||||
54029 . 54262) (\TEDIT.NEXT.OBJPIECE 54264 . 54497)) (54522 61965 (\TEDIT.CONCAT.PAGEFRAMES 54532 .
|
||||
59599) (\TEDIT.GET.PAGE.HEADINGS 59601 . 60630) (\TEDIT.CONCAT.INSTALL.HEADINGS 60632 . 61963)) (61966
|
||||
65573 (\TEDIT.MOVE.MSG 61976 . 64057) (\TEDIT.READONLY 64059 . 65571)) (65574 71465 (TEDIT.NCHARS
|
||||
65584 . 65957) (TEDIT.RPLCHARCODE 65959 . 68949) (TEDIT.NTHCHARCODE 68951 . 70994) (TEDIT.NTHCHAR
|
||||
70996 . 71463)) (71511 128555 (\TEDIT1 71521 . 73598) (\TEDIT.INSERT 73600 . 79713) (\TEDIT.MOVE 79715
|
||||
. 87813) (\TEDIT.COPY 87815 . 92421) (\TEDIT.REPLACE.SELPIECES 92423 . 96959) (
|
||||
\TEDIT.INSERT.SELPIECES 96961 . 99958) (\TEDIT.RESTARTFN 99960 . 102465) (\TEDIT.CHARDELETE 102467 .
|
||||
105396) (\TEDIT.COPYPIECE 105398 . 110560) (\TEDIT.APPLY.OBJFN 110562 . 113648) (\TEDIT.DELETE 113650
|
||||
. 118018) (\TEDIT.DIFFUSE.PARALOOKS 118020 . 120291) (\TEDIT.WORDDELETE 120293 . 121908) (
|
||||
\TEDIT.WORDDELETE.FORWARD 121910 . 123699) (\TEDIT.FINISHEDIT? 123701 . 128553)) (128556 129215 (
|
||||
\TEDIT.THELP 128566 . 129213)) (129249 138380 (\TEDIT.PARAPIECES 129259 . 131233) (\TEDIT.PARACHNOS
|
||||
131235 . 132127) (\TEDIT.PARA.FIRST 132129 . 135230) (\TEDIT.PARA.LAST 135232 . 138378)) (138381
|
||||
145476 (\TEDIT.WORD.FIRST 138391 . 142395) (\TEDIT.WORD.LAST 142397 . 145474)) (145677 145954 (
|
||||
TEDITSYSTEMDATE 145687 . 145952)) (146090 146297 (TEDIT.IMAGESOURCEP 146100 . 146295)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,10 +1,10 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10 FORMAT UTF-8)
|
||||
|
||||
(FILECREATED "13-Oct-2025 13:44:47" {WMEDLEY}<library>virtualkeyboards>KEYBOARDCONFIGS.;5 59521
|
||||
(FILECREATED "19-Feb-2026 22:32:05" {WMEDLEY}<library>virtualkeyboards>KEYBOARDCONFIGS.;6 59604
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:PREVIOUS-DATE "13-Oct-2025 12:03:23" {WMEDLEY}<library>virtualkeyboards>KEYBOARDCONFIGS.;4)
|
||||
:PREVIOUS-DATE "13-Oct-2025 13:44:47" {WMEDLEY}<library>virtualkeyboards>KEYBOARDCONFIGS.;5)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT KEYBOARDCONFIGSCOMS)
|
||||
@@ -57,11 +57,11 @@
|
||||
(F3 (F3 ITALIC))
|
||||
(F4 (F4 UCASE))
|
||||
(F5 (F5 STRIKE))
|
||||
(F6 (F6 ""))
|
||||
(F6 (F6 "^"))
|
||||
(F7 (F7 SUBSCR))
|
||||
(F8 (F8 SMALL))
|
||||
(F9 (F9 MARGIN))
|
||||
(F10 (F10 "¬"))
|
||||
(F10 (F10 "_"))
|
||||
(F11 (F11 ""))
|
||||
(F12 (F12 ""))
|
||||
(LOCK ("CAPS" "LOCK"))
|
||||
@@ -115,7 +115,7 @@
|
||||
(THREE (|3| %# NLS))
|
||||
(FOUR (|4| $ NLS))
|
||||
(FIVE (|5| %% NLS))
|
||||
(SIX (|6| ^ NLS))
|
||||
(SIX (|6| ↑ NLS))
|
||||
(SEVEN (|7| & NLS))
|
||||
(EIGHT (|8| * NLS))
|
||||
(NINE (|9| %( NLS))))
|
||||
@@ -234,7 +234,7 @@
|
||||
NIL
|
||||
((%" (%' %" NLS))
|
||||
(+ (= + NLS))
|
||||
(- (- _ NLS))
|
||||
(- (- ← NLS))
|
||||
(%: (; %: NLS))
|
||||
(< (%, < NLS))
|
||||
(> (%. > NLS))
|
||||
@@ -255,13 +255,13 @@
|
||||
(NUMERIC/ (/ /))
|
||||
(NUMERIC0 (INS |0| NLS))
|
||||
(NUMERIC1 (END |1| NLS))
|
||||
(NUMERIC2 (¯ |2| NLS))
|
||||
(NUMERIC2 (↓ |2| NLS))
|
||||
(NUMERIC3 (PGDN |3| NLS))
|
||||
(NUMERIC4 (¬ |4| NLS))
|
||||
(NUMERIC4 (_ |4| NLS))
|
||||
(NUMERIC5 (|5| |5|))
|
||||
(NUMERIC6 (® |6| NLS))
|
||||
(NUMERIC6 (→ |6| NLS))
|
||||
(NUMERIC7 (HOME |7| NLS))
|
||||
(NUMERIC8 ( |8| NLS))
|
||||
(NUMERIC8 (^ |8| NLS))
|
||||
(NUMERIC9 (PGUP |9| NLS))
|
||||
(NUMERIC= (= =))
|
||||
(RETURN (CR CR))
|
||||
@@ -274,17 +274,17 @@
|
||||
(F3 (ITALIC NOTITALIC NLS))
|
||||
(F4 (UCASE LCASE NLS))
|
||||
(F5 (STRIKEOUT NOTSTRIKEOUT NLS))
|
||||
(F6 ("" "" NLS))
|
||||
(F6 ("^" "^" NLS))
|
||||
(F7 (SUBSCRIPT SUPERSCRIPT NLS))
|
||||
(F8 (SMALLER LARGER NLS))
|
||||
(F9 (MARGINS NOTMARGINS NLS))
|
||||
(F10 ("¬" "¬" NLS))
|
||||
(F10 ("_" "_" NLS))
|
||||
(F11 (F11 NOTF11 NLS))
|
||||
(F12 (F12 NOTF12 NLS)))
|
||||
((%` 45 B)
|
||||
(~ 45 T)
|
||||
(|6| 2 B)
|
||||
(^ 2 T)
|
||||
(↑ 2 T)
|
||||
(%% 0 T)
|
||||
(|5| 0 B)
|
||||
($ 1 T)
|
||||
@@ -523,7 +523,7 @@
|
||||
(> (346 46 29 33))
|
||||
(%: (362 82 29 33))
|
||||
(<-%| (426 82 63 33))
|
||||
(^ (450 118 29 33))
|
||||
(↑ (450 118 29 33))
|
||||
(DEL (498 154 29 33))
|
||||
(R (162 118 29 33))
|
||||
(T (194 118 29 33))
|
||||
@@ -556,7 +556,7 @@
|
||||
(LF (LF LF))
|
||||
(LOCK LOCKDOWN . LOCKUP)
|
||||
(\ (\ %| NLS))
|
||||
(^ (_ ^ NLS))
|
||||
(↑ (← ↑ NLS))
|
||||
({ (%[ { NLS))
|
||||
(} (%] } NLS)))
|
||||
((BLANK-MIDDLE 30)
|
||||
@@ -643,8 +643,8 @@
|
||||
(%: 43)
|
||||
(CR 44)
|
||||
(<-%| 44)
|
||||
(_ 45)
|
||||
(^ 45)
|
||||
(← 45)
|
||||
(↑ 45)
|
||||
(r 48)
|
||||
(R 48)
|
||||
(t 49)
|
||||
@@ -744,7 +744,7 @@
|
||||
NIL
|
||||
((%" (%' %" NLS))
|
||||
(+ (= + NLS))
|
||||
(- (- _ NLS))
|
||||
(- (- ← NLS))
|
||||
(ESC (ESC %| NLS))
|
||||
(%: (; %: NLS))
|
||||
(< (%, < NLS))
|
||||
@@ -757,7 +757,7 @@
|
||||
(~ (%` ~ NLS)))
|
||||
((%` 45)
|
||||
(~ 45)
|
||||
(^ 2)
|
||||
(↑ 2)
|
||||
(|6| 2)
|
||||
(w 18)
|
||||
(W 18)
|
||||
@@ -951,7 +951,7 @@
|
||||
NIL
|
||||
((%" (%' %" NLS))
|
||||
(+ (= + NLS))
|
||||
(- (- _ NLS))
|
||||
(- (- ← NLS))
|
||||
(%: (; %: NLS))
|
||||
(< (%, < NLS))
|
||||
(<-%| (CR CR))
|
||||
@@ -962,21 +962,21 @@
|
||||
(KEYBOARD METADOWN . METAUP)
|
||||
(LOCK LOCKDOWN . LOCKUP)
|
||||
(NEXT (2,22 2,62 NLS))
|
||||
(NUMERIC* (NUMLK ´ NLS))
|
||||
(NUMERIC* (NUMLK × NLS))
|
||||
(NUMERIC+ (HELP 2,45 NLS))
|
||||
(NUMERIC, (\ %, NLS))
|
||||
(NUMERIC- (SCRL - NLS))
|
||||
(NUMERIC. (%| 21 NLS))
|
||||
(NUMERIC/ (BREAK ¸ NLS))
|
||||
(NUMERIC/ (BREAK ÷ NLS))
|
||||
(NUMERIC0 (INS |0| NLS))
|
||||
(NUMERIC1 (END |1| NLS))
|
||||
(NUMERIC2 (¯ |2| NLS))
|
||||
(NUMERIC2 (↓ |2| NLS))
|
||||
(NUMERIC3 (PGDN |3| NLS))
|
||||
(NUMERIC4 (¬ |4| NLS))
|
||||
(NUMERIC4 (_ |4| NLS))
|
||||
(NUMERIC5 (% |5| NLS))
|
||||
(NUMERIC6 (® |6| NLS))
|
||||
(NUMERIC6 (→ |6| NLS))
|
||||
(NUMERIC7 (HOME |7| NLS))
|
||||
(NUMERIC8 ( |8| NLS))
|
||||
(NUMERIC8 (^ |8| NLS))
|
||||
(NUMERIC9 (PGUP |9| NLS))
|
||||
(%` (%` ~ NLS))
|
||||
({ (%[ { NLS))
|
||||
@@ -987,7 +987,7 @@
|
||||
(|4| 1)
|
||||
($ 1)
|
||||
(|6| 2)
|
||||
(^ 2)
|
||||
(↑ 2)
|
||||
(e 3)
|
||||
(E 3)
|
||||
(|7| 4)
|
||||
@@ -1233,7 +1233,7 @@
|
||||
(%. (%. > NLS))
|
||||
(/ (/ ? NLS))
|
||||
(\ (\ %| NLS))
|
||||
(- (- _ NLS))
|
||||
(- (- ← NLS))
|
||||
(%` (%` ~ NLS))
|
||||
(%[ (%[ { NLS))
|
||||
(%] (%] } NLS))
|
||||
@@ -1249,13 +1249,13 @@
|
||||
(NUMERIC/ (/ /))
|
||||
(NUMERIC0 (INS |0| NLS))
|
||||
(NUMERIC1 (END |1| NLS))
|
||||
(NUMERIC2 (¯ |2| NLS))
|
||||
(NUMERIC2 (↓ |2| NLS))
|
||||
(NUMERIC3 (PGDN |3| NLS))
|
||||
(NUMERIC4 (¬ |4| NLS))
|
||||
(NUMERIC4 (_ |4| NLS))
|
||||
(NUMERIC5 (|5| |5|))
|
||||
(NUMERIC6 (® |6| NLS))
|
||||
(NUMERIC6 (→ |6| NLS))
|
||||
(NUMERIC7 (HOME |7| NLS))
|
||||
(NUMERIC8 ( |8| NLS))
|
||||
(NUMERIC8 (^ |8| NLS))
|
||||
(NUMERIC9 (PGUP |9| NLS))
|
||||
(NUMERICENTER (CR CR))
|
||||
(RALT METADOWN . METAUP)
|
||||
@@ -1264,11 +1264,11 @@
|
||||
(F3 (ITALIC NOTITALIC NLS))
|
||||
(F4 (UCASE LCASE NLS))
|
||||
(F5 (STRIKEOUT NOTSTRIKEOUT NLS))
|
||||
(F6 ("" "" NLS))
|
||||
(F6 ("^" "^" NLS))
|
||||
(F7 (SUBSCRIPT SUPERSCRIPT NLS))
|
||||
(F8 (SMALLER LARGER NLS))
|
||||
(F9 (MARGINS NOTMARGINS NLS))
|
||||
(F10 ("¬" "¬" NLS))
|
||||
(F10 ("_" "_" NLS))
|
||||
(F11 (F11 NOTF11 NLS))
|
||||
(F12 (F12 NOTF12 NLS)))
|
||||
((%' 28 B)
|
||||
@@ -1276,7 +1276,7 @@
|
||||
(%, 27 B)
|
||||
(< 27 T)
|
||||
(- 10 B)
|
||||
(_ 10 T)
|
||||
(← 10 T)
|
||||
(> 42 T)
|
||||
(%. 42 B)
|
||||
(/ 12 B)
|
||||
@@ -1286,7 +1286,7 @@
|
||||
(%# 16 T)
|
||||
($ 1 T)
|
||||
(%% 0 T)
|
||||
(^ 4 T)
|
||||
(↑ 4 T)
|
||||
(* 53 T)
|
||||
(%( 22 T)
|
||||
(%) 8 T)
|
||||
@@ -1494,7 +1494,7 @@
|
||||
(M (370 42 29 29))
|
||||
(; (402 42 29 29))
|
||||
(%: (434 42 29 29))
|
||||
(_ (466 42 29 29))
|
||||
(← (466 42 29 29))
|
||||
(RSHIFT (498 42 53 29))
|
||||
(LINEFEED (554 42 29 29))
|
||||
(CONTROL (106 74 53 29))
|
||||
@@ -1559,7 +1559,7 @@
|
||||
(ONE (|1| + NLS))
|
||||
(TWO (|2| %" NLS))
|
||||
(THREE (|3| * NLS))
|
||||
(FOUR (|4| ‡ NLS))
|
||||
(FOUR (|4| NLS))
|
||||
(SIX (|6| & NLS))
|
||||
(SEVEN (|7| / NLS))
|
||||
(EIGHT (|8| %( NLS))
|
||||
@@ -1567,7 +1567,7 @@
|
||||
(%: (%. %: NLS))
|
||||
(; (%, ; NLS))
|
||||
(? (%' ? NLS))
|
||||
(AUMLAUT (… „ NLS))
|
||||
(AUMLAUT ( NLS))
|
||||
(CAPSLOCK CTRLDOWN . CTRLUP)
|
||||
(CONTROL LOCKDOWN . LOCKUP)
|
||||
(CR (CR CR))
|
||||
@@ -1591,10 +1591,10 @@
|
||||
(NUMERIC8 (|8| |8|))
|
||||
(NUMERIC9 (|9| |9|))
|
||||
(NUMERIC= (= =))
|
||||
(OUMLAUT (‚ ” NLS))
|
||||
(UUMLAUT (Š <20> NLS))
|
||||
(OUMLAUT ( NLS))
|
||||
(UUMLAUT ( NLS))
|
||||
(%[ (%] %[ NLS))
|
||||
(_ (- _ NLS))
|
||||
(← (- ← NLS))
|
||||
({ (< { NLS))
|
||||
(} (> } NLS)))
|
||||
((HELP 0)
|
||||
@@ -1658,7 +1658,7 @@
|
||||
(%. 49)
|
||||
(%: 49)
|
||||
(- 50)
|
||||
(_ 50)
|
||||
(← 50)
|
||||
(RSHIFT 51)
|
||||
(LINEFEED 52)
|
||||
(CONTROL 53)
|
||||
|
||||
Binary file not shown.
215
lispusers/GITFNS
215
lispusers/GITFNS
@@ -1,12 +1,12 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10 :FORMAT :UTF-8)
|
||||
|
||||
(FILECREATED "28-Oct-2025 14:10:06" {WMEDLEY}<lispusers>GITFNS.;569 131593
|
||||
(FILECREATED " 2-Mar-2026 14:00:13" {WMEDLEY}<lispusers>GITFNS.;576 133513
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS GIT-WORKING-COMPARE-DIRECTORIES GIT-BRANCHES-COMPARE-DIRECTORIES)
|
||||
:CHANGES-TO (FNS GIT-MY-NEXT-BRANCH)
|
||||
|
||||
:PREVIOUS-DATE "28-Oct-2025 13:32:16" {WMEDLEY}<lispusers>GITFNS.;568)
|
||||
:PREVIOUS-DATE "26-Feb-2026 00:39:22" {WMEDLEY}<lispusers>GITFNS.;575)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT GITFNSCOMS)
|
||||
@@ -74,7 +74,7 @@
|
||||
|
||||
(* ;; "Differences")
|
||||
|
||||
(FNS GIT-BRANCH-DIFF GIT-COMMIT-DIFFS GIT-BRANCH-RELATIONS)
|
||||
(FNS GIT-BRANCH-DIFF GIT-COMMIT-DIFFS GIT-BRANCH-RELATIONS GIT-MODIFIED)
|
||||
|
||||
(* ;; "")
|
||||
|
||||
@@ -169,6 +169,7 @@
|
||||
|
||||
(GIT-MAKE-PROJECT
|
||||
[LAMBDA (PROJECTNAME CLONEPATH WORKINGPATH EXCLUSIONS DEFAULTSUBDIRS)
|
||||
(* ; "Edited 25-Feb-2026 23:25 by rmk")
|
||||
(* ; "Edited 25-Oct-2025 16:53 by rmk")
|
||||
(* ; "Edited 22-Oct-2025 12:45 by rmk")
|
||||
(* ; "Edited 20-Oct-2025 18:10 by rmk")
|
||||
@@ -234,9 +235,8 @@
|
||||
(CL:WHEN (SETQ GITIGNORE (INFILEP (PACKFILENAME.STRING 'NAME ".gitignore" 'BODY
|
||||
CLONEPATH)))
|
||||
(SETQ GITIGNORE (CL:WITH-OPEN-FILE (STREAM GITIGNORE :EXTERNAL-FORMAT :UTF-8)
|
||||
(bind L until (EOFP STREAM)
|
||||
while (SETQ L (CL:READ-LINE STREAM :EOF-ERROR-P NIL
|
||||
:EOF-VALUE NIL))
|
||||
(bind L until (EOFP STREAM) while (SETQ L (CL:READ-LINE
|
||||
STREAM NIL))
|
||||
unless (OR (EQ 0 (NCHARS L))
|
||||
(STRPOS "#" L)) collect L))))
|
||||
(SETQ EXCLUSIONS (CL:REMOVE-DUPLICATES (APPEND (for E inside EXCLUSIONS
|
||||
@@ -274,16 +274,16 @@
|
||||
"")
|
||||
"for " PROJECTNAME]
|
||||
(SETQ PROJECT (create GIT-PROJECT
|
||||
PROJECTNAME _ PROJECTNAME
|
||||
GITHOST _ (PACK* "{" (PSEUDOHOST PROJECTNAME CLONEPATH)
|
||||
PROJECTNAME ← PROJECTNAME
|
||||
GITHOST ← (PACK* "{" (PSEUDOHOST PROJECTNAME CLONEPATH)
|
||||
"}")
|
||||
WHOST _ (AND WORKINGPATH (PACK* "{" (PSEUDOHOST (CONCAT "W"
|
||||
WHOST ← (AND WORKINGPATH (PACK* "{" (PSEUDOHOST (CONCAT "W"
|
||||
PROJECTNAME)
|
||||
WORKINGPATH)
|
||||
"}"))
|
||||
EXCLUSIONS _ EXCLUSIONS
|
||||
DEFAULTSUBDIRS _ (MKLIST DEFAULTSUBDIRS)
|
||||
CLONEPATH _ CLONEPATH))
|
||||
EXCLUSIONS ← EXCLUSIONS
|
||||
DEFAULTSUBDIRS ← (MKLIST DEFAULTSUBDIRS)
|
||||
CLONEPATH ← CLONEPATH))
|
||||
(/RPLACD [OR (ASSOC PROJECTNAME GIT-PROJECTS)
|
||||
(CAR (push GIT-PROJECTS (CONS PROJECTNAME]
|
||||
PROJECT)
|
||||
@@ -358,7 +358,7 @@
|
||||
|
||||
(FIND-ANCESTOR-DIRECTORY
|
||||
[LAMBDA (STARTDIR PREDFN) (* ; "Edited 8-May-2022 12:17 by rmk")
|
||||
(BIND POS (A _ STARTDIR) WHILE (SETQ POS (STRPOS "/" A -2 NIL NIL NIL FILEDIRCASEARRAY T))
|
||||
(BIND POS (A ← STARTDIR) WHILE (SETQ POS (STRPOS "/" A -2 NIL NIL NIL FILEDIRCASEARRAY T))
|
||||
DO (SETQ A (SUBSTRING A 1 POS))
|
||||
(CL:WHEN (APPLY* PREDFN A)
|
||||
(RETURN A])
|
||||
@@ -372,7 +372,7 @@
|
||||
(GIT-CLONEP (GIT-PROJECT-PATH PROJECTNAME PROJECTPATH)
|
||||
T T)
|
||||
[FIND-ANCESTOR-DIRECTORY PROJECTPATH (FUNCTION (LAMBDA (A)
|
||||
(BIND D (GEN _ (\GENERATEFILES A NIL NIL 1))
|
||||
(BIND D (GEN ← (\GENERATEFILES A NIL NIL 1))
|
||||
WHILE (SETQ D (\GENERATENEXTFILE GEN))
|
||||
WHEN (GIT-CLONEP D T)
|
||||
DO (RETFROM (FUNCTION
|
||||
@@ -684,7 +684,7 @@
|
||||
|
||||
(GIT-MAINBRANCH? (GIT-WHICH-BRANCH PROJECT)
|
||||
PROJECT)
|
||||
(FOR MF GF DEST (MEDLEYSUBDIRS _ (MEDLEYSUBDIRS PROJECT)) INSIDE MFILES
|
||||
(FOR MF GF DEST (MEDLEYSUBDIRS ← (MEDLEYSUBDIRS PROJECT)) INSIDE MFILES
|
||||
COLLECT (SETQ MF (OR (FINDFILE MF NIL MEDLEYSUBDIRS)
|
||||
(ERROR "FILE NOT FOUND" MF)))
|
||||
(CL:UNLESS (STRING.EQUAL MF (INFILEP (PACKFILENAME 'VERSION NIL 'BODY MF))
|
||||
@@ -709,7 +709,7 @@
|
||||
(* ;; "Does anybody call this?")
|
||||
|
||||
(SETQ PROJECT (GIT-GET-PROJECT PROJECT))
|
||||
(FOR GF MF DEST (GITSUBDIRS _ (GITSUBDIRS PROJECT)) INSIDE GFILES
|
||||
(FOR GF MF DEST (GITSUBDIRS ← (GITSUBDIRS PROJECT)) INSIDE GFILES
|
||||
COLLECT (SETQ GF (OR (FINDFILE GF NIL GITSUBDIRS)
|
||||
(ERROR "FILE NOT FOUND" GF)))
|
||||
(SETQ MF (MFILE4GFILE GF))
|
||||
@@ -742,8 +742,8 @@
|
||||
"")])
|
||||
|
||||
(STRIPDIR
|
||||
[LAMBDA (FILE DIRECTORY) (* ; "Edited 18-Jan-2022 16:09 by rmk")
|
||||
(* ; "Edited 8-Nov-2021 11:50 by rmk:")
|
||||
[LAMBDA (FILE DIRECTORY) (* ; "Edited 18-Jan-2022 16:09 by rmk")
|
||||
(* ; "Edited 8-Nov-2021 11:50 by rmk:")
|
||||
(IF (STRPOS DIRECTORY FILE 1 NIL T NIL FILEDIRCASEARRAY)
|
||||
THEN (SUBSTRING FILE (ADD1 (NCHARS DIRECTORY)))
|
||||
ELSE FILE])
|
||||
@@ -1023,7 +1023,7 @@
|
||||
": ")
|
||||
(IF (EQ (CAR X)
|
||||
'Comments)
|
||||
THEN (FOR CC (POS _ (POSITION T)) IN (CDR X)
|
||||
THEN (FOR CC (POS ← (POSITION T)) IN (CDR X)
|
||||
DO (IF (EQ CC T)
|
||||
THEN (TERPRI T)
|
||||
ELSE (PRINTOUT T .TAB0 POS CC)))
|
||||
@@ -1163,7 +1163,7 @@
|
||||
|
||||
(* ;; "Returns the identifiers for commits in BRANCH1 but not in BUTNOTBRANCH2")
|
||||
|
||||
(GIT-COMMAND (CONCAT "git log --format=%"%%h%" %"" BRANCH1 "%" %"" BUTNOTBRANCH2 "%"")
|
||||
(GIT-COMMAND (CONCAT "git log --format=%"%%h%" %"" BRANCH1 "%" %"^" BUTNOTBRANCH2 "%"")
|
||||
NIL NIL PROJECT])
|
||||
|
||||
(GIT-BRANCH-RELATIONS
|
||||
@@ -1227,6 +1227,16 @@
|
||||
then (CONS MAIN (DREMOVE MAIN (SORT DATUM)))
|
||||
else (SORT DATUM]
|
||||
(RETURN (LIST SUPERSETS EQUALS])
|
||||
|
||||
(GIT-MODIFIED
|
||||
[LAMBDA (PROJECT) (* ; "Edited 25-Dec-2025 13:39 by rmk")
|
||||
|
||||
(* ;;
|
||||
"A list of files that have been modified M or introduced but not committed ??. see git help status")
|
||||
|
||||
(for X POS in (GIT-COMMAND "git status --porcelain")
|
||||
when (SETQ POS (OR (STRPOS " M " X NIL NIL NIL T)
|
||||
(STRPOS "?? " X NIL NIL NIL T))) collect (SUBSTRING X POS])
|
||||
)
|
||||
|
||||
|
||||
@@ -1353,7 +1363,7 @@
|
||||
(CL:WHEN (thereis B in BRANCHES suchthat (STRPOS "HEAD detached" B))
|
||||
(PRINTOUT T "Execute %"git gc%" to eliminate a branch with a detached HEAD" T))
|
||||
(CL:WHEN EXCLUDEMERGED
|
||||
(SETQ BRANCHES (for B (MAINBRANCH _ (GIT-MAINBRANCH PROJECT 'LOCAL)) in BRANCHES
|
||||
(SETQ BRANCHES (for B (MAINBRANCH ← (GIT-MAINBRANCH PROJECT 'LOCAL)) in BRANCHES
|
||||
when (EQUAL (GIT-COMMAND (CONCAT "git merge-base %"" B "%" %""
|
||||
MAINBRANCH "%""))
|
||||
(GIT-COMMAND (CONCAT "git rev-parse %"" B "%"")))
|
||||
@@ -1392,11 +1402,11 @@
|
||||
(CL:WHEN PIN?
|
||||
[SETQ BRANCHES (APPEND BRANCHES '((" Pin menu" 'PinMenu])
|
||||
(create MENU
|
||||
TITLE _ (OR TITLE (CONCAT (LENGTH BRANCHES)
|
||||
TITLE ← (OR TITLE (CONCAT (LENGTH BRANCHES)
|
||||
" branches"))
|
||||
ITEMS _ BRANCHES
|
||||
MENUFONT _ DEFAULTFONT
|
||||
WHENSELECTEDFN _ (FUNCTION GIT-BRANCH-WHENSELECTEDFN)))])
|
||||
ITEMS ← BRANCHES
|
||||
MENUFONT ← DEFAULTFONT
|
||||
WHENSELECTEDFN ← (FUNCTION GIT-BRANCH-WHENSELECTEDFN)))])
|
||||
|
||||
(GIT-BRANCH-WHENSELECTEDFN
|
||||
[LAMBDA (ITEM MENU BUTTON) (* ; "Edited 2-Oct-2025 23:08 by rmk")
|
||||
@@ -1446,20 +1456,20 @@
|
||||
eachtime [SETQ DRAFT (EQ 'true (JSON-GET JSOBJ 'isDraft] when (OR INCLUDEDRAFTS
|
||||
(NOT DRAFT))
|
||||
collect [SETQ PR (create PULLREQUEST
|
||||
PRNUMBER _ (JSON-GET JSOBJ 'number)
|
||||
PRNAME _ (JSON-GET JSOBJ 'headRefName)
|
||||
PRDESCRIPTION _ (JSON-GET JSOBJ 'title)
|
||||
PRSTATUS _ (CL:IF DRAFT
|
||||
PRNUMBER ← (JSON-GET JSOBJ 'number)
|
||||
PRNAME ← (JSON-GET JSOBJ 'headRefName)
|
||||
PRDESCRIPTION ← (JSON-GET JSOBJ 'title)
|
||||
PRSTATUS ← (CL:IF DRAFT
|
||||
'D
|
||||
(SELECTQ (MKATOM (JSON-GET JSOBJ 'reviewDecision))
|
||||
(CHANGES¬REQUESTED
|
||||
(CHANGES_REQUESTED
|
||||
'C)
|
||||
(REVIEW¬REQUIRED
|
||||
(REVIEW_REQUIRED
|
||||
" ")
|
||||
'A))
|
||||
PRPROJECT _ PROJECT
|
||||
PRURL _ (JSON-GET JSOBJ 'url)
|
||||
PRLOGIN _ (JSON-GET JSOBJ '(headRepositoryOwner login]
|
||||
PRPROJECT ← PROJECT
|
||||
PRURL ← (JSON-GET JSOBJ 'url)
|
||||
PRLOGIN ← (JSON-GET JSOBJ '(headRepositoryOwner login]
|
||||
(CL:WHEN (STRPOS ":" (fetch (PULLREQUEST PRNAME) of PR))
|
||||
|
||||
(* ;; "From Nick: Git commands to bring install and deal with the remotes:")
|
||||
@@ -1510,8 +1520,8 @@
|
||||
(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
|
||||
(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)
|
||||
" "
|
||||
@@ -1558,15 +1568,33 @@
|
||||
(GIT-BRANCH-NUM (OR BRANCH (GIT-WHICH-BRANCH PROJECT T])
|
||||
|
||||
(GIT-MY-NEXT-BRANCH
|
||||
[LAMBDA (PROJECT) (* ; "Edited 19-May-2022 14:08 by rmk")
|
||||
[LAMBDA (PROJECT) (* ; "Edited 2-Mar-2026 14:00 by rmk")
|
||||
(* ; "Edited 19-May-2022 14:08 by rmk")
|
||||
(* ; "Edited 8-Jan-2022 09:43 by rmk")
|
||||
|
||||
(* ;; "Figures out the number of my next incremental branch would be. ")
|
||||
|
||||
(PACK* (GIT-INITIALS)
|
||||
(ADD1 (OR (GIT-MY-BRANCHP (GIT-MY-CURRENT-BRANCH PROJECT)
|
||||
PROJECT)
|
||||
0])
|
||||
(LET (PROJECTLIST PROJECTENTRY NEXTNUM)
|
||||
(CL:WITH-OPEN-FILE (STRM "{LI}GIT-MY-CURRENT-BRANCH-NUMS;1" :DIRECTION :IO
|
||||
:IF-DOES-NOT-EXIST :CREATE :IF-EXISTS :OVERWRITE)
|
||||
(SETQ PROJECTLIST (CL:UNLESS (EQ 0 (GETEOFPTR STRM))
|
||||
(READ STRM)))
|
||||
(SETQ PROJECTENTRY (ASSOC (GIT-GET-PROJECT PROJECT 'PROJECTNAME)
|
||||
PROJECTLIST))
|
||||
(CL:UNLESS PROJECTENTRY
|
||||
(SETQ PROJECTENTRY (LIST (GIT-GET-PROJECT PROJECT 'PROJECTNAME)
|
||||
(OR (GIT-MY-BRANCHP (GIT-MY-CURRENT-BRANCH
|
||||
PROJECT)
|
||||
PROJECT)
|
||||
0)))
|
||||
(push PROJECTLIST PROJECTENTRY))
|
||||
(SETQ NEXTNUM (ADD1 (CADR PROJECTENTRY)))
|
||||
(RPLACA (CDR PROJECTENTRY)
|
||||
NEXTNUM)
|
||||
(SETFILEPTR STRM 0)
|
||||
(PRINT PROJECTLIST STRM)
|
||||
NEXTNUM])
|
||||
|
||||
(GIT-MY-BRANCHES
|
||||
[LAMBDA (PROJECT EXCLUDEMERGED INITS) (* ; "Edited 19-May-2022 19:10 by rmk")
|
||||
@@ -1647,14 +1675,14 @@
|
||||
(CL:WHEN (STRPOS "fatal: " (CAR LINES)
|
||||
1 NIL T)
|
||||
(ERROR "Could not remove worktree for " BRANCH))
|
||||
(* (DELFILE (CONCAT PATH "/.DS_Store"))
|
||||
(* (DELFILE (CONCAT PATH "/.DS←Store"))
|
||||
(GIT-COMMAND (CONCAT "rmdir " DIR) NIL
|
||||
NIL PROJECT))
|
||||
BRANCH])
|
||||
|
||||
(GIT-LIST-WORKTREES
|
||||
[LAMBDA NIL (* ; "Edited 12-Dec-2021 12:13 by rmk")
|
||||
(* ; "Edited 19-Nov-2021 18:53 by rmk:")
|
||||
[LAMBDA NIL (* ; "Edited 12-Dec-2021 12:13 by rmk")
|
||||
(* ; "Edited 19-Nov-2021 18:53 by rmk:")
|
||||
|
||||
(* ;; "The git command tells us what the clone thinks about it, but then we look to see what is actually in our worktrees directory, to make sure that the subdirectory wasn't deleted in a wy that the clone didn't know about.")
|
||||
|
||||
@@ -1880,14 +1908,14 @@
|
||||
|
||||
(replace (CDENTRY INFO2) of CDE
|
||||
with (create CDINFO
|
||||
FULLNAME _ (CADR MAP)
|
||||
DATE _ (CL:IF (EQ 'R (CADDR MAP))
|
||||
FULLNAME ← (CADR MAP)
|
||||
DATE ← (CL:IF (EQ 'R (CADDR MAP))
|
||||
" <-"
|
||||
" ==")
|
||||
LENGTH _ ""
|
||||
AUTHOR _ ""
|
||||
TYPE _ ""
|
||||
EOL _ ""))
|
||||
LENGTH ← ""
|
||||
AUTHOR ← ""
|
||||
TYPE ← ""
|
||||
EOL ← ""))
|
||||
(replace (CDENTRY DATEREL) of CDE
|
||||
with (CADDR MAP]
|
||||
(TERPRI T)
|
||||
@@ -1957,10 +1985,10 @@
|
||||
then (SETQ SUBDIRS (ALLSUBDIRS PROJECT))
|
||||
"ALL subdirectories"
|
||||
else SUBDIRS)))
|
||||
(for SUBDIR TITLE CDVAL (WPROJ _ (CONCAT "Working " (L-CASE (fetch PROJECTNAME of PROJECT)
|
||||
(for SUBDIR TITLE CDVAL (WPROJ ← (CONCAT "Working " (L-CASE (fetch PROJECTNAME of PROJECT)
|
||||
T)))
|
||||
(NENTRIES _ 0)
|
||||
(BRANCH2 _ (GIT-WHICH-BRANCH PROJECT T))
|
||||
(NENTRIES ← 0)
|
||||
(BRANCH2 ← (GIT-WHICH-BRANCH PROJECT T))
|
||||
first (PRINTOUT T "Comparing " SUBDIRSTRING 6 " of " WPROJ " and Git " BRANCH2 T)
|
||||
(BKSYSBUF " ") inside SUBDIRS
|
||||
collect (TERPRI T)
|
||||
@@ -2132,12 +2160,12 @@
|
||||
NIL]
|
||||
(CL:WHEN (OR COPYITEM COMPAREITEMS)
|
||||
(SELECTQ (MENU (CREATE MENU
|
||||
TITLE _ (CONCAT (WINDOWPROP WINDOW 'SUBDIR)
|
||||
TITLE ← (CONCAT (WINDOWPROP WINDOW 'SUBDIR)
|
||||
"/"
|
||||
(FETCH MATCHNAME OF CDENTRY))
|
||||
ITEMS _ (APPEND COPYITEM COMPAREITEMS)
|
||||
MENUFONT _ FONT
|
||||
MENUTITLEFONT _ FONT))
|
||||
ITEMS ← (APPEND COPYITEM COMPAREITEMS)
|
||||
MENUFONT ← FONT
|
||||
MENUTITLEFONT ← FONT))
|
||||
(TOGIT (CL:WHEN (TOGIT (FETCH (CDINFO FULLNAME) OF INFO1)
|
||||
WINDOW)
|
||||
(IMAGEOBJPROP OBJ 'COPIED T)
|
||||
@@ -2162,18 +2190,18 @@
|
||||
NIL)))])
|
||||
|
||||
(GIT-CD-LABELFN
|
||||
[LAMBDA (FILE1 FILE2 USERDATA) (* ; "Edited 5-Jan-2022 15:10 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 12:25 by rmk")
|
||||
[LAMBDA (FILE1 FILE2 USERDATA) (* ; "Edited 5-Jan-2022 15:10 by rmk")
|
||||
(* ; "Edited 16-Dec-2021 12:25 by rmk")
|
||||
(* ; "Edited 13-Dec-2021 22:13 by rmk")
|
||||
(DECLARE (USEDFREE CDVALUE))
|
||||
(LET (NC B LABEL1 LABEL2)
|
||||
(CL:WHEN (SETQ NC (FETCH NCDIR OF (FETCH CDMAXNC1 OF CDVALUE)))
|
||||
(SETQ LABEL1 (SLASHIT (SUBSTRING FILE1 (ADD1 NC))
|
||||
(SETQ LABEL1 (SLASHIT (SUBSTRING FILE1 (ADD1 NC))
|
||||
T))
|
||||
(CL:WHEN (SETQ B (LISTGET USERDATA 'BRANCH1))
|
||||
(SETQ LABEL1 (CONCAT B "/" LABEL1))))
|
||||
(CL:WHEN (SETQ NC (FETCH NCDIR OF (FETCH CDMAXNC2 OF CDVALUE)))
|
||||
(SETQ LABEL2 (SLASHIT (SUBSTRING FILE2 (ADD1 NC))
|
||||
(SETQ LABEL2 (SLASHIT (SUBSTRING FILE2 (ADD1 NC))
|
||||
T))
|
||||
(CL:WHEN (SETQ B (LISTGET USERDATA 'BRANCH2))
|
||||
(SETQ LABEL2 (CONCAT B "/" LABEL2))))
|
||||
@@ -2367,15 +2395,15 @@
|
||||
NIL])
|
||||
|
||||
(GIT-RESULT-TO-LINES
|
||||
[LAMBDA (FILE ALL) (* ; "Edited 31-Mar-2025 15:19 by rmk")
|
||||
[LAMBDA (FILE ALL) (* ; "Edited 25-Feb-2026 23:24 by rmk")
|
||||
(* ; "Edited 31-Mar-2025 15:19 by rmk")
|
||||
(* ; "Edited 16-Jul-2022 22:21 by rmk")
|
||||
|
||||
(* ;; "Suppress .git lines unless ALL SYSTEM-EXTERNALFORMAT may make the wrong guess, but at least we ensure here that lines get broken.")
|
||||
|
||||
(CL:WITH-OPEN-FILE (STREAM FILE :DIRECTION :INPUT :EXTERNAL-FORMAT (LIST (SYSTEM-EXTERNALFORMAT)
|
||||
'ANY))
|
||||
(bind LINE until (EOFP STREAM) when [PROGN (SETQ LINE (CL:READ-LINE STREAM :EOF-ERROR-P
|
||||
NIL :EOF-VALUE NIL))
|
||||
(bind LINE until (EOFP STREAM) when [PROGN (SETQ LINE (CL:READ-LINE STREAM NIL))
|
||||
(OR ALL (NOT (STRPOS ".git" LINE 1]
|
||||
collect LINE])
|
||||
|
||||
@@ -2394,32 +2422,33 @@
|
||||
|
||||
(PUTPROPS GITFNS FILETYPE :TCOMPL)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (4196 21002 (GIT-CLONEP 4206 . 5637) (GIT-INIT 5639 . 6269) (GIT-MAKE-PROJECT 6271 .
|
||||
14060) (GIT-GET-PROJECT 14062 . 15987) (GIT-PUT-PROJECT-FIELD 15989 . 17630) (GIT-PROJECT-PATH 17632
|
||||
. 18676) (FIND-ANCESTOR-DIRECTORY 18678 . 19027) (GIT-FIND-CLONE 19029 . 20110) (GIT-MAINBRANCH 20112
|
||||
. 20507) (GIT-MAINBRANCH? 20509 . 21000)) (26465 31394 (PRC-COMMAND 26475 . 31392)) (31450 34238 (
|
||||
ALLSUBDIRS 31460 . 32746) (MEDLEYSUBDIRS 32748 . 33441) (GITSUBDIRS 33443 . 34236)) (34239 36640 (
|
||||
TOGIT 34249 . 35655) (FROMGIT 35657 . 36638)) (36641 39644 (MYMEDLEYSUBDIR 36651 . 37107) (GITSUBDIR
|
||||
37109 . 37552) (STRIPDIR 37554 . 37925) (STRIPHOST 37927 . 38167) (STRIPNAME 38169 . 38922) (
|
||||
STRIPWHERE 38924 . 39642)) (39645 41880 (GFILE4MFILE 39655 . 40351) (MFILE4GFILE 40353 . 40922) (
|
||||
GIT-REPO-FILENAME 40924 . 41878)) (41929 52184 (GIT-COMMIT 41939 . 42765) (GIT-PUSH 42767 . 43527) (
|
||||
GIT-PULL 43529 . 44281) (GIT-APPROVAL 44283 . 44632) (GIT-GET-FILE 44634 . 46549) (GIT-FILE-EXISTS?
|
||||
46551 . 46825) (GIT-REMOTE-UPDATE 46827 . 47662) (GIT-REMOTE-ADD 47664 . 47971) (GIT-FILE-DATE 47973
|
||||
. 49020) (GIT-FILE-HISTORY 49022 . 50956) (GIT-PRINT-FILE-HISTORY 50958 . 52008) (GIT-FETCH 52010 .
|
||||
52182)) (52214 63694 (GIT-BRANCH-DIFF 52224 . 59113) (GIT-COMMIT-DIFFS 59115 . 60006) (
|
||||
GIT-BRANCH-RELATIONS 60008 . 63692)) (63739 82478 (GIT-BRANCH-NUM 63749 . 64322) (GIT-CHECKOUT 64324
|
||||
. 65610) (GIT-WHICH-BRANCH 65612 . 66019) (GIT-MAKE-BRANCH 66021 . 68600) (GIT-BRANCHES 68602 . 71197
|
||||
) (GIT-BRANCH-EXISTS? 71199 . 72070) (GIT-PICK-BRANCH 72072 . 72562) (GIT-BRANCH-MENU 72564 . 73445) (
|
||||
GIT-BRANCH-WHENSELECTEDFN 73447 . 74986) (GIT-PULL-REQUESTS 74988 . 78859) (GIT-SHORT-BRANCH-NAME
|
||||
78861 . 79152) (GIT-LONG-NAME 79154 . 79471) (GIT-PRC-BRANCHES 79473 . 82476)) (82508 85956 (
|
||||
GIT-MY-CURRENT-BRANCH 82518 . 82888) (GIT-MY-BRANCHP 82890 . 83508) (GIT-MY-NEXT-BRANCH 83510 . 84004)
|
||||
(GIT-MY-BRANCHES 84006 . 85954)) (86002 90077 (GIT-ADD-WORKTREE 86012 . 87619) (GIT-REMOVE-WORKTREE
|
||||
87621 . 88551) (GIT-LIST-WORKTREES 88553 . 89357) (WORKTREEDIR 89359 . 90075)) (90125 123133 (
|
||||
GIT-GET-DIFFERENT-FILES 90135 . 97043) (GIT-BRANCHES-COMPARE-DIRECTORIES 97045 . 104672) (
|
||||
GIT-WORKING-COMPARE-DIRECTORIES 104674 . 110470) (GIT-COMPARE-WORKTREE 110472 . 114450) (
|
||||
GITCDOBJBUTTONFN 114452 . 118942) (GIT-CD-LABELFN 118944 . 120026) (GIT-CD-MENUFN 120028 . 121114) (
|
||||
GIT-WORKING-COMPARE-FILES 121116 . 121736) (GIT-BRANCHES-COMPARE-FILES 121738 . 122902) (
|
||||
GIT-PR-COMPARE 122904 . 123131)) (123203 131526 (CDGITDIR 123213 . 123900) (GIT-COMMAND 123902 .
|
||||
125460) (GITORIGIN 125462 . 126159) (GIT-INITIALS 126161 . 126465) (GIT-COMMAND-TO-FILE 126467 .
|
||||
129952) (GIT-RESULT-TO-LINES 129954 . 130859) (STRIPLOCAL 130861 . 131524)))))
|
||||
(FILEMAP (NIL (4178 21056 (GIT-CLONEP 4188 . 5619) (GIT-INIT 5621 . 6251) (GIT-MAKE-PROJECT 6253 .
|
||||
14110) (GIT-GET-PROJECT 14112 . 16037) (GIT-PUT-PROJECT-FIELD 16039 . 17680) (GIT-PROJECT-PATH 17682
|
||||
. 18726) (FIND-ANCESTOR-DIRECTORY 18728 . 19079) (GIT-FIND-CLONE 19081 . 20164) (GIT-MAINBRANCH 20166
|
||||
. 20561) (GIT-MAINBRANCH? 20563 . 21054)) (26519 31448 (PRC-COMMAND 26529 . 31446)) (31504 34292 (
|
||||
ALLSUBDIRS 31514 . 32800) (MEDLEYSUBDIRS 32802 . 33495) (GITSUBDIRS 33497 . 34290)) (34293 36698 (
|
||||
TOGIT 34303 . 35711) (FROMGIT 35713 . 36696)) (36699 39709 (MYMEDLEYSUBDIR 36709 . 37165) (GITSUBDIR
|
||||
37167 . 37610) (STRIPDIR 37612 . 37990) (STRIPHOST 37992 . 38232) (STRIPNAME 38234 . 38987) (
|
||||
STRIPWHERE 38989 . 39707)) (39710 41945 (GFILE4MFILE 39720 . 40416) (MFILE4GFILE 40418 . 40987) (
|
||||
GIT-REPO-FILENAME 40989 . 41943)) (41994 52251 (GIT-COMMIT 42004 . 42830) (GIT-PUSH 42832 . 43592) (
|
||||
GIT-PULL 43594 . 44346) (GIT-APPROVAL 44348 . 44697) (GIT-GET-FILE 44699 . 46614) (GIT-FILE-EXISTS?
|
||||
46616 . 46890) (GIT-REMOTE-UPDATE 46892 . 47727) (GIT-REMOTE-ADD 47729 . 48036) (GIT-FILE-DATE 48038
|
||||
. 49085) (GIT-FILE-HISTORY 49087 . 51021) (GIT-PRINT-FILE-HISTORY 51023 . 52075) (GIT-FETCH 52077 .
|
||||
52249)) (52281 64233 (GIT-BRANCH-DIFF 52291 . 59180) (GIT-COMMIT-DIFFS 59182 . 60073) (
|
||||
GIT-BRANCH-RELATIONS 60075 . 63759) (GIT-MODIFIED 63761 . 64231)) (64278 83045 (GIT-BRANCH-NUM 64288
|
||||
. 64861) (GIT-CHECKOUT 64863 . 66149) (GIT-WHICH-BRANCH 66151 . 66558) (GIT-MAKE-BRANCH 66560 . 69139
|
||||
) (GIT-BRANCHES 69141 . 71738) (GIT-BRANCH-EXISTS? 71740 . 72611) (GIT-PICK-BRANCH 72613 . 73103) (
|
||||
GIT-BRANCH-MENU 73105 . 73994) (GIT-BRANCH-WHENSELECTEDFN 73996 . 75535) (GIT-PULL-REQUESTS 75537 .
|
||||
79422) (GIT-SHORT-BRANCH-NAME 79424 . 79715) (GIT-LONG-NAME 79717 . 80034) (GIT-PRC-BRANCHES 80036 .
|
||||
83043)) (83075 87829 (GIT-MY-CURRENT-BRANCH 83085 . 83455) (GIT-MY-BRANCHP 83457 . 84075) (
|
||||
GIT-MY-NEXT-BRANCH 84077 . 85877) (GIT-MY-BRANCHES 85879 . 87827)) (87875 91959 (GIT-ADD-WORKTREE
|
||||
87885 . 89492) (GIT-REMOVE-WORKTREE 89494 . 90426) (GIT-LIST-WORKTREES 90428 . 91239) (WORKTREEDIR
|
||||
91241 . 91957)) (92007 125045 (GIT-GET-DIFFERENT-FILES 92017 . 98925) (
|
||||
GIT-BRANCHES-COMPARE-DIRECTORIES 98927 . 106566) (GIT-WORKING-COMPARE-DIRECTORIES 106568 . 112370) (
|
||||
GIT-COMPARE-WORKTREE 112372 . 116350) (GITCDOBJBUTTONFN 116352 . 120850) (GIT-CD-LABELFN 120852 .
|
||||
121938) (GIT-CD-MENUFN 121940 . 123026) (GIT-WORKING-COMPARE-FILES 123028 . 123648) (
|
||||
GIT-BRANCHES-COMPARE-FILES 123650 . 124814) (GIT-PR-COMPARE 124816 . 125043)) (125115 133446 (CDGITDIR
|
||||
125125 . 125812) (GIT-COMMAND 125814 . 127372) (GITORIGIN 127374 . 128071) (GIT-INITIALS 128073 .
|
||||
128377) (GIT-COMMAND-TO-FILE 128379 . 131864) (GIT-RESULT-TO-LINES 131866 . 132779) (STRIPLOCAL 132781
|
||||
. 133444)))))
|
||||
STOP
|
||||
|
||||
Binary file not shown.
@@ -1,26 +1,27 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
|
||||
|
||||
(FILECREATED " 1-Feb-2026 13:03:18" {WMEDLEY}<lispusers>ISO8859IO.;19 23459
|
||||
(FILECREATED "22-Feb-2026 12:22:12" {WMEDLEY}<lispusers>ISO8859IO.;22 21861
|
||||
|
||||
:EDIT-BY rmk
|
||||
|
||||
:CHANGES-TO (FNS \MAKERECODEMAP MAKEISOFORMAT \8859OUTCHARFN \8859INCCODEFN \8859PEEKCCODEFN)
|
||||
:CHANGES-TO (FNS ISO1TOMSTRING MTOISO1STRING)
|
||||
(VARS ISO8859IOCOMS)
|
||||
|
||||
:PREVIOUS-DATE " 8-Aug-2021 13:22:31" {WMEDLEY}<lispusers>ISO8859IO.;11)
|
||||
:PREVIOUS-DATE " 2-Feb-2026 23:20:20" {WMEDLEY}<lispusers>ISO8859IO.;20)
|
||||
|
||||
|
||||
(PRETTYCOMPRINT ISO8859IOCOMS)
|
||||
|
||||
(RPAQQ ISO8859IOCOMS
|
||||
(
|
||||
(* ;; "This package defines EXTERNALFORMATS for files that are encoded in either ISO8859/1, the standard IBM extended ascii, or the usual MAC encoding.")
|
||||
(* ;; "This package defines EXTERNALFORMATS for files that are encoded in ISIO8859/1, the standard IBM extended ascii, or the legacy MAC encoding.")
|
||||
|
||||
(COMS (* ; "ISO8859/1")
|
||||
(FNS \8859OUTCHARFN \8859INCCODEFN \8859PEEKCCODEFN)
|
||||
(GLOBALVARS *MCCSTOISO8859MAP* *ISO8859TOMCCSMAP*)
|
||||
(FNS MAKEISOFORMAT)
|
||||
(P (MAKEISOFORMAT)))
|
||||
[COMS (* ; "ISO8859/1")
|
||||
(FNS ISO1TOMCODE MTOISO1CODE \CREATE.ISO1.FORMAT)
|
||||
(FNS ISO1TOMSTRING MTOISO1STRING)
|
||||
(VARS ISO1TOMCCS)
|
||||
(GLOBALVARS ISO1TOMCCS)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY (P (\CREATE.ISO1.FORMAT]
|
||||
(COMS (* ; "IBM-PC Extended Ascii")
|
||||
(FNS \IBMOUTCHARFN \IBMINCCODEFN \IBMPEEKCCODEFN)
|
||||
(GLOBALVARS *XEROXTOIBMMAP* *IBMTOXEROXMAP*)
|
||||
@@ -37,7 +38,7 @@
|
||||
|
||||
|
||||
(* ;;
|
||||
"This package defines EXTERNALFORMATS for files that are encoded in either ISO8859/1, the standard IBM extended ascii, or the usual MAC encoding."
|
||||
"This package defines EXTERNALFORMATS for files that are encoded in ISIO8859/1, the standard IBM extended ascii, or the legacy MAC encoding."
|
||||
)
|
||||
|
||||
|
||||
@@ -47,152 +48,150 @@
|
||||
|
||||
(DEFINEQ
|
||||
|
||||
(\8859OUTCHARFN
|
||||
[LAMBDA (STREAM CHARCODE)
|
||||
(DECLARE (GLOBALVARS *XEROXTOISO8859MAP*)) (* ; "Edited 1-Feb-2026 10:11 by rmk")
|
||||
(* ; "Edited 8-Aug-2021 13:21 by rmk:")
|
||||
(* ; "Edited 7-Dec-95 14:34 by ")
|
||||
(* ; "Edited 7-Dec-95 14:32 by ")
|
||||
(ISO1TOMCODE
|
||||
[LAMBDA (ICODE) (* ; "Edited 5-Feb-2026 12:09 by rmk")
|
||||
(* ; "Edited 2-Feb-2026 23:14 by rmk")
|
||||
(* ; "Edited 7-Sep-2025 22:39 by rmk")
|
||||
(* ; "Edited 3-Sep-2025 10:21 by rmk")
|
||||
(* ; "Edited 7-Aug-2025 09:37 by rmk")
|
||||
|
||||
(* ;; "Converts CHARCODE from internal encoding to ISO8859 before printing.")
|
||||
(* ;; "ISO codes are 8bit, MCODES maybe not. Caller shouldn't pass a fat code.")
|
||||
|
||||
(* ;; "Unconverted codes are left unchanged (no error).")
|
||||
(OR [CAR (find PAIR in ISO1TOMCCS suchthat (EQ ICODE (CADR PAIR]
|
||||
ICODE])
|
||||
|
||||
(* ;; "If any remaining codes are out of charset 0, the streams external format will be used. ")
|
||||
(MTOISO1CODE
|
||||
[LAMBDA (MCODE) (* ; "Edited 5-Feb-2026 12:26 by rmk")
|
||||
(* ; "Edited 2-Feb-2026 22:58 by rmk")
|
||||
(OR (CADR (ASSOC MCODE ISO1TOMCCS))
|
||||
MCODE])
|
||||
|
||||
(IF (EQ CHARCODE (CHARCODE EOL))
|
||||
THEN (FREPLACE (STREAM CHARPOSITION) OF STREAM WITH 0)
|
||||
(\BOUTEOL STREAM)
|
||||
ELSE (CHANGE (FFETCH (STREAM CHARPOSITION) OF STREAM)
|
||||
(IPLUS16 1 DATUM))
|
||||
(\BOUT STREAM (IF (IGREATERP CHARCODE 127)
|
||||
THEN
|
||||
|
||||
(* ;; "We know that ISO doesn't have floating accents, so only singletons are returned. We also know that it agrees with MCCS on first 128, except for cirumflex and underscore")
|
||||
|
||||
(\RECODECCODE CHARCODE *MCCSTOISO8859MAP*)
|
||||
ELSE CHARCODE])
|
||||
|
||||
(\8859INCCODEFN
|
||||
[LAMBDA (STRM COUNTP) (* ; "Edited 1-Feb-2026 10:10 by rmk")
|
||||
(* ; "Edited 6-Aug-2021 16:10 by rmk:")
|
||||
(* ; "Edited 7-Dec-95 15:24 by ")
|
||||
(* ; "Edited 7-Dec-95 15:19 by ")
|
||||
(DECLARE (USEDFREE *BYTECOUNTER*))
|
||||
(CL:WHEN COUNTP (SETQ *BYTECOUNTER* 1))
|
||||
(\RECODECCODE (\BIN STRM)
|
||||
*ISO8859TOMCCSMAP*])
|
||||
|
||||
(\8859PEEKCCODEFN
|
||||
[LAMBDA (STRM NOERROR) (* ; "Edited 1-Feb-2026 10:10 by rmk")
|
||||
(* ; "Edited 5-May-2021 17:44 by rmk:")
|
||||
(* ; "Edited 3-Jan-96 14:21 by ")
|
||||
(* ; "Edited 7-Dec-95 15:51 by ")
|
||||
(* ; "Edited 7-Dec-95 15:19 by ")
|
||||
(\RECODECCODE (\PEEKCCODE STRM NOERROR)
|
||||
*ISO8859TOMCCSMAP*])
|
||||
)
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS *MCCSTOISO8859MAP* *ISO8859TOMCCSMAP*)
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(MAKEISOFORMAT
|
||||
[LAMBDA NIL (* ; "Edited 1-Feb-2026 11:18 by rmk")
|
||||
(\CREATE.ISO1.FORMAT
|
||||
[LAMBDA NIL (* ; "Edited 5-Feb-2026 10:42 by rmk")
|
||||
(* ; "Edited 2-Feb-2026 23:37 by rmk")
|
||||
(* ; "Edited 1-Feb-2026 11:18 by rmk")
|
||||
(* ; "Edited 5-Aug-2021 22:15 by rmk:")
|
||||
(* ; "Edited 9-Mar-99 17:19 by rmk:")
|
||||
(* ; "Edited 7-Dec-95 16:24 by ")
|
||||
(* ; "Edited 7-Dec-95 16:20 by ")
|
||||
(LET [(MCCSTOISO '(("0,255" "0,136")
|
||||
("0,254" "0,137")
|
||||
("357,41" "0,240")
|
||||
("357,153" "0,246")
|
||||
("43,42" "0,250")
|
||||
("0,323" "0,251")
|
||||
("0,343" "0,252")
|
||||
("357,152" "0,254")
|
||||
("357,43" "0,255")
|
||||
("0,322" "0,256")
|
||||
("43,176" "0,257")
|
||||
("43,47" "0,264")
|
||||
("0,313" "0,270")
|
||||
("0,321" "0,271")
|
||||
("0,353" "0.272")
|
||||
("361,41" "0,300")
|
||||
("361,42" "0,301")
|
||||
("361,43" "0,302")
|
||||
("361,44" "0,303")
|
||||
("361,47" "0,304")
|
||||
("361,50" "0,305")
|
||||
("0,341" "0,306")
|
||||
("361,55" "0,307")
|
||||
("361,60" "0,310")
|
||||
("361,61" "0,311")
|
||||
("361,62" "0,312")
|
||||
("361,65" "0,313")
|
||||
("361,76" "0,314")
|
||||
("361,77" "0,315")
|
||||
("361,100" "0,316")
|
||||
("361,104" "0,317")
|
||||
("0,342" "0,320")
|
||||
("361,114" "0,321")
|
||||
("361,117" "0,322")
|
||||
("361,120" "0,323")
|
||||
("361,121" "0,324")
|
||||
("361,122" "0,325")
|
||||
("361,124" "0,326")
|
||||
("0,264" "0,327")
|
||||
("0,351" "0,330")
|
||||
("361,137" "0,331")
|
||||
("361,140" "0,332")
|
||||
("361,141" "0,333")
|
||||
("361,145" "0,334")
|
||||
("361,153" "0,335")
|
||||
("0,354" "0,336")
|
||||
("0,373" "0,337")
|
||||
("361,241" "0,340")
|
||||
("361,242" "0,341")
|
||||
("361,243" "0,342")
|
||||
("361,244" "0,343")
|
||||
("361,247" "0,344")
|
||||
("361,250" "0,345")
|
||||
("0,361" "0,346")
|
||||
("361,255" "0,347")
|
||||
("361,260" "0,350")
|
||||
("361,261" "0,351")
|
||||
("361,262" "0,352")
|
||||
("361,265" "0,353")
|
||||
("361,276" "0,354")
|
||||
("361,277" "0,355")
|
||||
("361,300" "0,356")
|
||||
("361,304" "0,357")
|
||||
("0,363" "0,360")
|
||||
("361,314" "0,361")
|
||||
("361,317" "0,362")
|
||||
("361,320" "0,363")
|
||||
("361,321" "0,364")
|
||||
("361,322" "0,365")
|
||||
("361,324" "0,366")
|
||||
("0,270" "0,367")
|
||||
("0,371" "0,370")
|
||||
("361,337" "0,371")
|
||||
("361,340" "0,372")
|
||||
("361,341" "0,373")
|
||||
("361,345" "0,374")
|
||||
("361,353" "0,375")
|
||||
("0,374" "0,376")
|
||||
("361,355" "0,377")
|
||||
("361,155" "Meta,170"]
|
||||
(SETQ *MCCSTOISO8859MAP* (\MAKERECODEMAP MCCSTOISO))
|
||||
(SETQ *ISO8859TOMCCSMAP* (\MAKERECODEMAP MCCSTOISO T)))
|
||||
(MAKE-EXTERNALFORMAT :ISO8859/1 (FUNCTION \8859INCCODEFN)
|
||||
(FUNCTION \8859PEEKCCODEFN)
|
||||
(FUNCTION \COMMONBACKCCODEFN)
|
||||
(FUNCTION \8859OUTCHARFN])
|
||||
(MAKE-EXTERNALFORMAT :ISO8859/1 [FUNCTION (LAMBDA (STREAM COUNTP)
|
||||
(ISO1TOMCODE (\THROUGHIN STREAM COUNTP]
|
||||
[FUNCTION (LAMBDA (STREAM NOERRORFLG)
|
||||
(ISO1TOMCODE (\PEEKBIN STREAM NOERRORFLG]
|
||||
(FUNCTION \THROUGHBACKCCODE)
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION NILL)
|
||||
NIL NIL (FUNCTION MTOISO1STRING)
|
||||
NIL
|
||||
(FUNCTION NILL)
|
||||
(FUNCTION ISO1TOMSTRING])
|
||||
)
|
||||
(DEFINEQ
|
||||
|
||||
(ISO1TOMSTRING
|
||||
[LAMBDA (ISTRING DESTRUCTIVE) (* ; "Edited 22-Feb-2026 12:21 by rmk")
|
||||
(* ; "Edited 5-Feb-2026 11:01 by rmk")
|
||||
(* ; "Edited 2-Feb-2026 23:46 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 12:14 by rmk")
|
||||
(* ; "Edited 29-Apr-2025 13:08 by rmk")
|
||||
|
||||
(* ;; "Converts ISO8859/1 codes to MCCS codes in MSTRING.")
|
||||
|
||||
(for I ICODE (MSTRING _ (CL:IF DESTRUCTIVE
|
||||
ISTRING
|
||||
(CONCAT ISTRING))) from 1 while (SETQ ICODE (NTHCHARCODE ISTRING I))
|
||||
do (RPLCHARCODE MSTRING I (ISO1TOMCODE ICODE)) finally (RETURN MSTRING])
|
||||
|
||||
(MTOISO1STRING
|
||||
[LAMBDA (MSTRING DESTRUCTIVE) (* ; "Edited 22-Feb-2026 12:22 by rmk")
|
||||
(* ; "Edited 2-Feb-2026 23:47 by rmk")
|
||||
(* ; "Edited 2-Sep-2025 12:22 by rmk")
|
||||
(* ; "Edited 29-Apr-2025 13:08 by rmk")
|
||||
|
||||
(* ;; "Converts MCCS to ISO8859/1 codes in MSTRING.")
|
||||
|
||||
(for I MCODE (ISTRING _ (CL:IF DESTRUCTIVE
|
||||
MSTRING
|
||||
(CONCAT MSTRING))) from 1 while (SETQ MCODE (NTHCHARCODE MSTRING I))
|
||||
do (RPLCHARCODE ISTRING I (MTOISO1CODE MCODE)) finally (RETURN ISTRING])
|
||||
)
|
||||
|
||||
(MAKEISOFORMAT)
|
||||
(RPAQQ ISO1TOMCCS
|
||||
((94 8593)
|
||||
(95 8592)
|
||||
(169 8216)
|
||||
(170 8220)
|
||||
(172 95)
|
||||
(173 94)
|
||||
(174 8594)
|
||||
(175 8595)
|
||||
(180 215)
|
||||
(184 247)
|
||||
(185 8217)
|
||||
(186 8221)
|
||||
(193 768)
|
||||
(194 769)
|
||||
(195 770)
|
||||
(196 771)
|
||||
(197 772)
|
||||
(198 774)
|
||||
(199 775)
|
||||
(200 776)
|
||||
(202 778)
|
||||
(203 807)
|
||||
(204 818)
|
||||
(205 779)
|
||||
(206 808)
|
||||
(207 780)
|
||||
(208 8213)
|
||||
(209 185)
|
||||
(210 174)
|
||||
(211 169)
|
||||
(212 8482)
|
||||
(213 9834)
|
||||
(220 8539)
|
||||
(221 8540)
|
||||
(222 8541)
|
||||
(223 8542)
|
||||
(224 8486)
|
||||
(225 198)
|
||||
(226 208)
|
||||
(227 170)
|
||||
(228 294)
|
||||
(229 567)
|
||||
(230 306)
|
||||
(231 319)
|
||||
(232 321)
|
||||
(233 216)
|
||||
(234 338)
|
||||
(235 186)
|
||||
(236 222)
|
||||
(237 358)
|
||||
(238 330)
|
||||
(239 329)
|
||||
(240 312)
|
||||
(241 230)
|
||||
(242 273)
|
||||
(243 240)
|
||||
(244 295)
|
||||
(245 305)
|
||||
(246 307)
|
||||
(247 320)
|
||||
(248 322)
|
||||
(249 248)
|
||||
(250 339)
|
||||
(251 223)
|
||||
(252 254)
|
||||
(253 359)
|
||||
(254 331)))
|
||||
(DECLARE%: DOEVAL@COMPILE DONTCOPY
|
||||
|
||||
(GLOBALVARS ISO1TOMCCS)
|
||||
)
|
||||
(DECLARE%: DONTEVAL@LOAD DOCOPY
|
||||
|
||||
(\CREATE.ISO1.FORMAT)
|
||||
)
|
||||
|
||||
|
||||
|
||||
@@ -553,10 +552,10 @@
|
||||
(* ; "Edited 21-Jun-95 10:18 by rmk:")
|
||||
|
||||
(* ;; "Recodes a singleton charcode. Leaves everything else unchanged.")
|
||||
|
||||
(LET [(CSMAP (CL:SVREF MAPARRAY (LRSH CODE 8]
|
||||
(OR (AND CSMAP (CL:SVREF CSMAP (LOGAND CODE 255)))
|
||||
CODE])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
|
||||
(LET [(CSMAP (CL:SVREF MAPARRAY (LRSH CODE 8]
|
||||
(OR (AND CSMAP (CL:SVREF CSMAP (LOGAND CODE 255)))
|
||||
CODE])
|
||||
)
|
||||
(DECLARE%: DONTCOPY
|
||||
(FILEMAP (NIL (1834 4154 (ISO1TOMCODE 1844 . 2593) (MTOISO1CODE 2595 . 2885) (\CREATE.ISO1.FORMAT 2887
|
||||
|
||||
Binary file not shown.
1
loops
Submodule
1
loops
Submodule
Submodule loops added at 8508dd0d9a
1
maiko
Submodule
1
maiko
Submodule
Submodule maiko added at d791b1d332
1
notecards
Submodule
1
notecards
Submodule
Submodule notecards added at 32defaee14
Binary file not shown.
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -1,503 +0,0 @@
|
||||
;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
|
||||
;;;
|
||||
;;; *************************************************************************
|
||||
;;; Copyright (c) 1991 Venue
|
||||
;;; All rights reserved.
|
||||
;;; *************************************************************************
|
||||
;;;
|
||||
;;; Bootstrapping the meta-braid.
|
||||
;;;
|
||||
;;; The code in this file takes the early definitions that have been saved
|
||||
;;; up and actually builds those class objects. This work is largely driven
|
||||
;;; off of those class definitions, but the fact that STANDARD-CLASS is the
|
||||
;;; class of all metaclasses in the braid is built into this code pretty
|
||||
;;; deeply.
|
||||
;;;
|
||||
;;;
|
||||
|
||||
(in-package 'clos)
|
||||
|
||||
(defun early-class-definition (class-name)
|
||||
(or (find class-name *early-class-definitions* :key #'ecd-class-name)
|
||||
(error "~S is not a class in *early-class-definitions*." class-name)))
|
||||
|
||||
(defun canonical-slot-name (canonical-slot)
|
||||
(getf canonical-slot :name))
|
||||
|
||||
(defun early-collect-inheritance (class-name)
|
||||
(declare (values slots cpl default-initargs direct-subclasses))
|
||||
(let ((cpl (early-collect-cpl class-name)))
|
||||
(values (early-collect-slots cpl)
|
||||
cpl
|
||||
(early-collect-default-initargs cpl)
|
||||
(gathering1 (collecting)
|
||||
(dolist (definition *early-class-definitions*)
|
||||
(when (memq class-name (ecd-superclass-names definition))
|
||||
(gather1 (ecd-class-name definition))))))))
|
||||
|
||||
(defun early-collect-cpl (class-name)
|
||||
(labels ((walk (c)
|
||||
(let* ((definition (early-class-definition c))
|
||||
(supers (ecd-superclass-names definition)))
|
||||
(cons c
|
||||
(apply #'append (mapcar #'early-collect-cpl supers))))))
|
||||
(remove-duplicates (walk class-name) :from-end nil :test #'eq)))
|
||||
|
||||
(defun early-collect-slots (cpl)
|
||||
(let* ((definitions (mapcar #'early-class-definition cpl))
|
||||
(super-slots (mapcar #'ecd-canonical-slots definitions))
|
||||
(slots (apply #'append (reverse super-slots))))
|
||||
(dolist (s1 slots)
|
||||
(let ((name1 (canonical-slot-name s1)))
|
||||
(dolist (s2 (cdr (memq s1 slots)))
|
||||
(when (eq name1 (canonical-slot-name s2))
|
||||
(error "More than one early class defines a slot with the~%~
|
||||
name ~S. This can't work because the bootstrap~%~
|
||||
object system doesn't know how to compute effective~%~
|
||||
slots."
|
||||
name1)))))
|
||||
slots))
|
||||
|
||||
(defun early-collect-default-initargs (cpl)
|
||||
(let ((default-initargs ()))
|
||||
(dolist (class-name cpl)
|
||||
(let ((definition (early-class-definition class-name)))
|
||||
(dolist (option (ecd-other-initargs definition))
|
||||
(unless (eq (car option) :default-initargs)
|
||||
(error "The defclass option ~S is not supported by the bootstrap~%~
|
||||
object system."
|
||||
(car option)))
|
||||
(setq default-initargs
|
||||
(nconc default-initargs (reverse (cdr option)))))))
|
||||
(reverse default-initargs)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; bootstrap-get-slot and bootstrap-set-slot are used to access and change
|
||||
;;; the values of slots during bootstrapping. During bootstrapping, there
|
||||
;;; are only two kinds of objects whose slots we need to access, CLASSes
|
||||
;;; and SLOTDs. The first argument to these functions tells whether the
|
||||
;;; object is a CLASS or a SLOTD.
|
||||
;;;
|
||||
;;; Note that the way this works it stores the slot in the same place in
|
||||
;;; memory that the full object system will expect to find it later. This
|
||||
;;; is critical to the bootstrapping process, the whole changeover to the
|
||||
;;; full object system is predicated on this.
|
||||
;;;
|
||||
;;; One important point is that the layout of standard classes and standard
|
||||
;;; slots must be computed the same way in this file as it is by the full
|
||||
;;; object system later.
|
||||
;;;
|
||||
(defun bootstrap-get-slot (type object slot-name)
|
||||
(let ((index (bootstrap-slot-index type slot-name)))
|
||||
(svref (std-instance-slots object) index)))
|
||||
|
||||
(defun bootstrap-set-slot (type object slot-name new-value)
|
||||
(let ((index (bootstrap-slot-index type slot-name)))
|
||||
(setf (svref (std-instance-slots object) index) new-value)))
|
||||
|
||||
(defvar *std-class-slots*
|
||||
(mapcar #'canonical-slot-name
|
||||
(early-collect-inheritance 'standard-class)))
|
||||
|
||||
(defvar *bin-class-slots*
|
||||
(mapcar #'canonical-slot-name
|
||||
(early-collect-inheritance 'built-in-class)))
|
||||
|
||||
(defvar *std-slotd-slots*
|
||||
(mapcar #'canonical-slot-name
|
||||
(early-collect-inheritance 'standard-slot-definition)))
|
||||
|
||||
(defun bootstrap-slot-index (type slot-name)
|
||||
(or (position slot-name (ecase type
|
||||
(std-class *std-class-slots*)
|
||||
(bin-class *bin-class-slots*)
|
||||
(std-slotd *std-slotd-slots*)))
|
||||
(error "~S not found" slot-name)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; bootstrap-meta-braid
|
||||
;;;
|
||||
;;; This function builds the base metabraid from the early class definitions.
|
||||
;;;
|
||||
(defun bootstrap-meta-braid ()
|
||||
(let* ((std-class-size (length *std-class-slots*))
|
||||
(std-class (%allocate-instance--class std-class-size))
|
||||
(std-class-wrapper (make-wrapper std-class))
|
||||
(built-in-class (%allocate-instance--class std-class-size))
|
||||
(built-in-class-wrapper (make-wrapper built-in-class))
|
||||
(direct-slotd (%allocate-instance--class std-class-size))
|
||||
(effective-slotd (%allocate-instance--class std-class-size))
|
||||
(direct-slotd-wrapper (make-wrapper direct-slotd))
|
||||
(effective-slotd-wrapper (make-wrapper effective-slotd)))
|
||||
;;
|
||||
;; First, make a class metaobject for each of the early classes. For
|
||||
;; each metaobject we also set its wrapper. Except for the class T,
|
||||
;; the wrapper is always that of STANDARD-CLASS.
|
||||
;;
|
||||
(dolist (definition *early-class-definitions*)
|
||||
(let* ((name (ecd-class-name definition))
|
||||
(meta (ecd-metaclass definition))
|
||||
(class (case name
|
||||
(standard-class std-class)
|
||||
(standard-direct-slot-definition direct-slotd)
|
||||
(standard-effective-slot-definition effective-slotd)
|
||||
(built-in-class built-in-class)
|
||||
(otherwise
|
||||
(%allocate-instance--class std-class-size)))))
|
||||
(unless (eq name t)
|
||||
(inform-type-system-about-class class name))
|
||||
(setf (std-instance-wrapper class)
|
||||
(ecase meta
|
||||
(standard-class std-class-wrapper)
|
||||
(built-in-class built-in-class-wrapper)))
|
||||
(setf (find-class name) class)))
|
||||
;;
|
||||
;;
|
||||
;;
|
||||
(dolist (definition *early-class-definitions*)
|
||||
(let ((name (ecd-class-name definition))
|
||||
(source (ecd-source definition))
|
||||
(direct-supers (ecd-superclass-names definition))
|
||||
(direct-slots (ecd-canonical-slots definition))
|
||||
(other-initargs (ecd-other-initargs definition)))
|
||||
(let ((direct-default-initargs
|
||||
(getf other-initargs :default-initargs)))
|
||||
(multiple-value-bind (slots cpl default-initargs direct-subclasses)
|
||||
(early-collect-inheritance name)
|
||||
(let* ((class (find-class name))
|
||||
(wrapper
|
||||
(cond
|
||||
((eq class std-class) std-class-wrapper)
|
||||
((eq class direct-slotd) direct-slotd-wrapper)
|
||||
((eq class effective-slotd) effective-slotd-wrapper)
|
||||
((eq class built-in-class) built-in-class-wrapper)
|
||||
(t (make-wrapper class))))
|
||||
(proto nil))
|
||||
(cond ((eq name 't)
|
||||
(setq *the-wrapper-of-t* wrapper
|
||||
*the-class-t* class))
|
||||
((memq name '(standard-object
|
||||
standard-class
|
||||
standard-effective-slot-definition))
|
||||
(set (intern (format nil "*THE-CLASS-~A*" (symbol-name name))
|
||||
*the-clos-package*)
|
||||
class)))
|
||||
(dolist (slot slots)
|
||||
(unless (eq (getf slot :allocation :instance) :instance)
|
||||
(error "Slot allocation ~S not supported in bootstrap.")))
|
||||
|
||||
(setf (wrapper-instance-slots-layout wrapper)
|
||||
(mapcar #'canonical-slot-name slots))
|
||||
(setf (wrapper-class-slots wrapper)
|
||||
())
|
||||
|
||||
(setq proto (%allocate-instance--class (length slots)))
|
||||
(setf (std-instance-wrapper proto) wrapper)
|
||||
|
||||
(setq direct-slots
|
||||
(bootstrap-make-slot-definitions name direct-slots
|
||||
direct-slotd-wrapper nil))
|
||||
(setq slots
|
||||
(bootstrap-make-slot-definitions name slots
|
||||
effective-slotd-wrapper t))
|
||||
|
||||
(bootstrap-initialize-std-class
|
||||
class name source
|
||||
direct-supers direct-subclasses cpl wrapper
|
||||
direct-slots slots direct-default-initargs default-initargs
|
||||
proto)
|
||||
|
||||
(dolist (slotd direct-slots)
|
||||
(bootstrap-accessor-definitions
|
||||
name
|
||||
(bootstrap-get-slot 'std-slotd slotd 'name)
|
||||
(bootstrap-get-slot 'std-slotd slotd 'readers)
|
||||
(bootstrap-get-slot 'std-slotd slotd 'writers))))))))))
|
||||
|
||||
(defun bootstrap-accessor-definitions (class-name slot-name readers writers)
|
||||
(flet ((do-reader-definition (reader)
|
||||
(add-method
|
||||
(ensure-generic-function reader)
|
||||
(make-a-method
|
||||
'standard-reader-method
|
||||
()
|
||||
(list class-name)
|
||||
(list class-name)
|
||||
(make-std-reader-method-function slot-name)
|
||||
"automatically generated reader method"
|
||||
slot-name)))
|
||||
(do-writer-definition (writer)
|
||||
(add-method
|
||||
(ensure-generic-function writer)
|
||||
(make-a-method
|
||||
'standard-writer-method
|
||||
()
|
||||
(list 'new-value class-name)
|
||||
(list 't class-name)
|
||||
(make-std-writer-method-function slot-name)
|
||||
"automatically generated writer method"
|
||||
slot-name))))
|
||||
(dolist (reader readers) (do-reader-definition reader))
|
||||
(dolist (writer writers) (do-writer-definition writer))))
|
||||
|
||||
;;;
|
||||
;;; Initialize a standard class metaobject.
|
||||
;;;
|
||||
(defun bootstrap-initialize-std-class
|
||||
(class
|
||||
name definition-source direct-supers direct-subclasses cpl wrapper
|
||||
direct-slots slots direct-default-initargs default-initargs proto)
|
||||
(flet ((classes (names) (mapcar #'find-class names))
|
||||
(set-slot (slot-name value)
|
||||
(bootstrap-set-slot 'std-class class slot-name value)))
|
||||
|
||||
(set-slot 'name name)
|
||||
(set-slot 'source definition-source)
|
||||
(set-slot 'class-precedence-list (classes cpl))
|
||||
(set-slot 'direct-superclasses (classes direct-supers))
|
||||
(set-slot 'direct-slots direct-slots)
|
||||
(set-slot 'direct-subclasses (classes direct-subclasses))
|
||||
(set-slot 'direct-methods (cons nil nil))
|
||||
(set-slot 'no-of-instance-slots (length slots))
|
||||
(set-slot 'slots slots)
|
||||
(set-slot 'wrapper wrapper)
|
||||
(set-slot 'prototype proto)
|
||||
(set-slot 'plist
|
||||
`(,@(and direct-default-initargs
|
||||
`(direct-default-initargs ,direct-default-initargs))
|
||||
,@(and default-initargs
|
||||
`(default-initargs ,default-initargs))))
|
||||
))
|
||||
|
||||
;;;
|
||||
;;; Initialize a built-in-class metaobject.
|
||||
;;;
|
||||
(defun bootstrap-initialize-bin-class
|
||||
(class
|
||||
name definition-source direct-supers direct-subclasses cpl wrapper)
|
||||
(flet ((classes (names) (mapcar #'find-class names))
|
||||
(set-slot (slot-name value)
|
||||
(bootstrap-set-slot 'bin-class class slot-name value)))
|
||||
|
||||
(set-slot 'name name)
|
||||
(set-slot 'source definition-source)
|
||||
(set-slot 'direct-superclasses (classes direct-supers))
|
||||
(set-slot 'direct-subclasses (classes direct-subclasses))
|
||||
(set-slot 'direct-methods (cons nil nil))
|
||||
(set-slot 'class-precedence-list (classes cpl))
|
||||
(set-slot 'wrapper wrapper)))
|
||||
|
||||
(defun bootstrap-make-slot-definitions (name slots wrapper e-p)
|
||||
(mapcar #'(lambda (slot) (bootstrap-make-slot-definition name slot wrapper e-p))
|
||||
slots))
|
||||
|
||||
(defun bootstrap-make-slot-definition (name slot wrapper e-p)
|
||||
(let ((slotd (%allocate-instance--class (length *std-slotd-slots*))))
|
||||
(setf (std-instance-wrapper slotd) wrapper)
|
||||
(flet ((get-val (name) (getf slot name))
|
||||
(set-val (name val) (bootstrap-set-slot 'std-slotd slotd name val)))
|
||||
(set-val 'name (get-val :name))
|
||||
(set-val 'initform (get-val :initform))
|
||||
(set-val 'initfunction (get-val :initfunction))
|
||||
(set-val 'initargs (get-val :initargs))
|
||||
(set-val 'readers (get-val :readers))
|
||||
(set-val 'writers (get-val :writers))
|
||||
(set-val 'allocation :instance)
|
||||
(set-val 'type (get-val :type))
|
||||
(set-val 'class nil)
|
||||
(set-val 'instance-index nil)
|
||||
(when (and (eq name 'standard-class) (eq (get-val :name) 'slots) e-p)
|
||||
(setq *the-eslotd-standard-class-slots* slotd))
|
||||
slotd)))
|
||||
|
||||
(defun bootstrap-built-in-classes ()
|
||||
;;
|
||||
;; First make sure that all the supers listed in *built-in-class-lattice*
|
||||
;; are themselves defined by *built-in-class-lattice*. This is just to
|
||||
;; check for typos and other sorts of brainos.
|
||||
;;
|
||||
(dolist (e *built-in-classes*)
|
||||
(dolist (super (cadr e))
|
||||
(unless (or (eq super 't)
|
||||
(assq super *built-in-classes*))
|
||||
(error "In *built-in-classes*: ~S has ~S as a super,~%~
|
||||
but ~S is not itself a class in *built-in-classes*."
|
||||
(car e) super super))))
|
||||
|
||||
;;
|
||||
;; In the first pass, we create a skeletal object to be bound to the
|
||||
;; class name.
|
||||
;;
|
||||
(let* ((built-in-class (find-class 'built-in-class))
|
||||
(built-in-class-wrapper (class-wrapper built-in-class))
|
||||
(bin-class-size (length *bin-class-slots*)))
|
||||
(dolist (e *built-in-classes*)
|
||||
(let ((class (%allocate-instance--class bin-class-size)))
|
||||
(setf (std-instance-wrapper class) built-in-class-wrapper)
|
||||
(setf (find-class (car e)) class))))
|
||||
|
||||
;;
|
||||
;; In the second pass, we initialize the class objects.
|
||||
;;
|
||||
(dolist (e *built-in-classes*)
|
||||
(destructuring-bind (name supers subs cpl) e
|
||||
(let* ((class (find-class name))
|
||||
(wrapper (make-wrapper class)))
|
||||
(set (get-built-in-class-symbol name) class)
|
||||
(set (get-built-in-wrapper-symbol name) wrapper)
|
||||
|
||||
(setf (wrapper-instance-slots-layout wrapper) ()
|
||||
(wrapper-class-slots wrapper) ())
|
||||
|
||||
(bootstrap-initialize-bin-class class
|
||||
name nil
|
||||
supers subs
|
||||
(cons name cpl) wrapper)
|
||||
))))
|
||||
|
||||
|
||||
;;;
|
||||
;;;
|
||||
;;;
|
||||
|
||||
(defun class-of (x) (wrapper-class (wrapper-of x)))
|
||||
|
||||
(defun wrapper-of (x)
|
||||
(or (and (std-instance-p x)
|
||||
(std-instance-wrapper x))
|
||||
(and (fsc-instance-p x)
|
||||
(fsc-instance-wrapper x))
|
||||
(built-in-wrapper-of x)
|
||||
(error "Can't determine wrapper of ~S" x)))
|
||||
|
||||
|
||||
(eval-when (compile eval)
|
||||
|
||||
(defun make-built-in-class-subs ()
|
||||
(mapcar #'(lambda (e)
|
||||
(let ((class (car e))
|
||||
(class-subs ()))
|
||||
(dolist (s *built-in-classes*)
|
||||
(when (memq class (cadr s)) (pushnew (car s) class-subs)))
|
||||
(cons class class-subs)))
|
||||
(cons '(t) *built-in-classes*)))
|
||||
|
||||
(defun make-built-in-class-tree ()
|
||||
(let ((subs (make-built-in-class-subs)))
|
||||
(labels ((descend (class)
|
||||
(cons class (mapcar #'descend (cdr (assq class subs))))))
|
||||
(descend 't))))
|
||||
|
||||
(defun make-built-in-wrapper-of-body ()
|
||||
(make-built-in-wrapper-of-body-1 (make-built-in-class-tree)
|
||||
'x
|
||||
#'get-built-in-wrapper-symbol))
|
||||
|
||||
(defun make-built-in-wrapper-of-body-1 (tree var get-symbol)
|
||||
(let ((*specials* ()))
|
||||
(declare (special *specials*))
|
||||
(let ((inner (make-built-in-wrapper-of-body-2 tree var get-symbol)))
|
||||
`(locally (declare (special .,*specials*)) ,inner))))
|
||||
|
||||
(defun make-built-in-wrapper-of-body-2 (tree var get-symbol)
|
||||
(declare (special *specials*))
|
||||
(let ((symbol (funcall get-symbol (car tree))))
|
||||
(push symbol *specials*)
|
||||
(let ((sub-tests
|
||||
(mapcar #'(lambda (x)
|
||||
(make-built-in-wrapper-of-body-2 x var get-symbol))
|
||||
(cdr tree))))
|
||||
`(and (typep ,var ',(car tree))
|
||||
,(if sub-tests
|
||||
`(or ,.sub-tests ,symbol)
|
||||
symbol)))))
|
||||
)
|
||||
|
||||
(defun built-in-wrapper-of (x)
|
||||
#.(make-built-in-wrapper-of-body))
|
||||
|
||||
|
||||
|
||||
|
||||
(eval-when (load eval)
|
||||
(clrhash *find-class*)
|
||||
(bootstrap-meta-braid)
|
||||
(bootstrap-built-in-classes)
|
||||
(setq *boot-state* 'braid)
|
||||
(setf (symbol-function 'load-defclass) #'real-load-defclass)
|
||||
)
|
||||
|
||||
|
||||
;;;
|
||||
;;; All of these method definitions must appear here because the bootstrap
|
||||
;;; only allows one method per generic function until the braid is fully
|
||||
;;; built.
|
||||
;;;
|
||||
(defmethod print-object (instance stream)
|
||||
(printing-random-thing (instance stream)
|
||||
(let ((name (class-name (class-of instance))))
|
||||
(if name
|
||||
(format stream "~S" name)
|
||||
(format stream "Instance")))))
|
||||
|
||||
(defmethod print-object ((class class) stream)
|
||||
(named-object-print-function class stream))
|
||||
|
||||
(defmethod print-object ((slotd standard-slot-definition) stream)
|
||||
(named-object-print-function slotd stream))
|
||||
|
||||
(defun named-object-print-function (instance stream
|
||||
&optional (extra nil extra-p))
|
||||
(printing-random-thing (instance stream)
|
||||
(if extra-p
|
||||
(format stream "~A ~S ~:S"
|
||||
(capitalize-words (class-name (class-of instance)))
|
||||
(slot-value-or-default instance 'name)
|
||||
extra)
|
||||
(format stream "~A ~S"
|
||||
(capitalize-words (class-name (class-of instance)))
|
||||
(slot-value-or-default instance 'name)))))
|
||||
|
||||
|
||||
;;;
|
||||
;;;
|
||||
;;;
|
||||
;(defmethod shared-initialize :after ((class class) slot-names &key name)
|
||||
; (declare (ignore slot-names))
|
||||
; (setf (slot-value class 'name) name))
|
||||
;
|
||||
;
|
||||
;(defmethod shared-initialize :after ((class std-class)
|
||||
; slot-names
|
||||
; &key direct-superclasses
|
||||
; direct-slots)
|
||||
; (declare (ignore slot-names))
|
||||
; (setf (slot-value class 'direct-superclasses) direct-superclasses
|
||||
; (slot-value class 'direct-slots) direct-slots))
|
||||
|
||||
;;;
|
||||
;;;
|
||||
;;;
|
||||
(defmethod shared-initialize :after ((slotd standard-slot-definition)
|
||||
slot-names
|
||||
&key class
|
||||
name
|
||||
initform
|
||||
initfunction
|
||||
initargs
|
||||
(allocation :instance)
|
||||
(type t)
|
||||
readers
|
||||
writers)
|
||||
(declare (ignore slot-names))
|
||||
(setf (slot-value slotd 'name) name
|
||||
(slot-value slotd 'initform) initform
|
||||
(slot-value slotd 'initfunction) initfunction
|
||||
(slot-value slotd 'initargs) initargs
|
||||
(slot-value slotd 'allocation) (if (eq allocation :class) class allocation)
|
||||
(slot-value slotd 'type) type
|
||||
(slot-value slotd 'readers) readers
|
||||
(slot-value slotd 'writers) writers))
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,260 +0,0 @@
|
||||
(DEFINE-FILE-INFO PACKAGE "XCL" READTABLE "XCL")
|
||||
(il:filecreated "28-Aug-87 18:42:36" il:{phylum}<clos>clos-env-internal.\;1 8356
|
||||
|
||||
il:|changes| il:|to:| (il:vars il:clos-env-internalcoms)
|
||||
(il:props (il:clos-env-internal il:makefile-environment))
|
||||
(il:functions stack-eql stack-pointer-frame stack-frame-valid-p
|
||||
stack-frame-fn-header stack-frame-pc fnheader-debugging-info
|
||||
stack-frame-name compiled-closure-fnheader compiled-closure-env)
|
||||
)
|
||||
|
||||
|
||||
; Copyright (c) 1987 by Xerox Corporation. All rights reserved.
|
||||
|
||||
(il:prettycomprint il:clos-env-internalcoms)
|
||||
|
||||
(il:rpaqq il:clos-env-internalcoms (
|
||||
|
||||
(il:* il:|;;;| "***************************************")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation. All rights reserved.")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| "")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| "Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws.")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " ")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| "This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification.")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " ")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| "Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " CommonLoops Coordinator")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " Xerox Artifical Intelligence Systems")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " 2400 Hanover St.")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " Palo Alto, CA 94303")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| "")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " *************************************************************************")
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| "")
|
||||
|
||||
(il:declare\: il:dontcopy (il:prop il:makefile-environment
|
||||
il:clos-env-internal))
|
||||
(il:* il:\;
|
||||
"We're off to hack the system...")
|
||||
|
||||
(il:declare\: il:eval@compile il:dontcopy (il:files clos::abc)
|
||||
|
||||
|
||||
(il:* il:|;;| "The Deltas and The East and The Freeze")
|
||||
)
|
||||
(il:functions stack-eql stack-pointer-frame stack-frame-valid-p
|
||||
stack-frame-fn-header stack-frame-pc
|
||||
fnheader-debugging-info stack-frame-name
|
||||
compiled-closure-fnheader compiled-closure-env)))
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| "***************************************")
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " Copyright (c) 1987 Xerox Corporation. All rights reserved.")
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| "")
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;|
|
||||
"Use and copying of this software and preparation of derivative works based upon this software are permitted. Any distribution of this software or derivative works must comply with all applicable United States export control laws."
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " ")
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;|
|
||||
"This software is made available AS IS, and Xerox Corporation makes no warranty about the software, its performance or its conformity to any specification."
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " ")
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;|
|
||||
"Any person obtaining a copy of this software is requested to send their name and post office or electronic mail address to:"
|
||||
)
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " CommonLoops Coordinator")
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " Xerox Artifical Intelligence Systems")
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " 2400 Hanover St.")
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " Palo Alto, CA 94303")
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| "(or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)")
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| "")
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " Suggestions, comments and requests for improvements are also welcome.")
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| " *************************************************************************")
|
||||
|
||||
|
||||
|
||||
|
||||
(il:* il:|;;;| "")
|
||||
|
||||
(il:declare\: il:dontcopy
|
||||
|
||||
(il:putprops il:clos-env-internal il:makefile-environment (:package "XCL" :readtable "XCL"))
|
||||
)
|
||||
|
||||
|
||||
|
||||
(il:* il:\; "We're off to hack the system...")
|
||||
|
||||
(il:declare\: il:eval@compile il:dontcopy
|
||||
(il:filesload clos::abc)
|
||||
)
|
||||
|
||||
(defun stack-eql (x y) "Test two stack pointers for equality" (and (il:stackp x)
|
||||
(il:stackp y)
|
||||
(eql (il:fetch (il:stackp il:edfxp
|
||||
)
|
||||
il:of x)
|
||||
(il:fetch (il:stackp il:edfxp
|
||||
)
|
||||
il:of y))))
|
||||
|
||||
|
||||
(defun stack-pointer-frame (stack-pointer) (il:|fetch| (il:stackp il:edfxp) il:|of| stack-pointer))
|
||||
|
||||
|
||||
(defun stack-frame-valid-p (frame) (not (il:|fetch| (il:fx il:invalidp) il:|of| frame)))
|
||||
|
||||
|
||||
(defun stack-frame-fn-header (frame) (il:|fetch| (il:fx il:fnheader) il:|of| frame))
|
||||
|
||||
|
||||
(defun stack-frame-pc (frame) (il:|fetch| (il:fx il:pc) il:|of| frame))
|
||||
|
||||
|
||||
(defun fnheader-debugging-info (fnheader) (let* ((start-pc (il:fetch (il:fnheader il:startpc)
|
||||
il:of fnheader))
|
||||
(name-table-words
|
||||
(let ((size (il:fetch (il:fnheader il:ntsize)
|
||||
il:of fnheader)))
|
||||
(if (zerop size)
|
||||
il:wordsperquad
|
||||
(* size 2))))
|
||||
(past-name-table-in-words (+ (il:fetch (il:fnheader
|
||||
|
||||
il:overheadwords
|
||||
)
|
||||
il:of fnheader)
|
||||
name-table-words)))
|
||||
(and (= (- start-pc (* il:bytesperword
|
||||
past-name-table-in-words))
|
||||
il:bytespercell)
|
||||
|
||||
(il:* il:|;;| "It's got a debugging-info list.")
|
||||
|
||||
(il:\\getbaseptr fnheader
|
||||
past-name-table-in-words))))
|
||||
|
||||
|
||||
(defun stack-frame-name (frame) (il:|fetch| (il:fx il:framename) il:|of| frame))
|
||||
|
||||
|
||||
(defun compiled-closure-fnheader (closure) (il:|fetch| (il:compiled-closure il:fnheader) il:|of|
|
||||
closure))
|
||||
|
||||
|
||||
(defun compiled-closure-env (closure) (il:fetch (il:compiled-closure il:environment) il:of closure))
|
||||
|
||||
(il:putprops il:clos-env-internal il:copyright ("Xerox Corporation" 1987))
|
||||
(il:declare\: il:dontcopy
|
||||
(il:filemap (nil)))
|
||||
il:stop
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,254 +0,0 @@
|
||||
;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*-
|
||||
;;;
|
||||
;;; *************************************************************************
|
||||
;;; Copyright (c) 1991 Venue
|
||||
;;; All rights reserved.
|
||||
;;; *************************************************************************
|
||||
;;;
|
||||
|
||||
(in-package 'clos)
|
||||
|
||||
(defun make-effective-method-function (generic-function form)
|
||||
(flet ((name-function (fn) (set-function-name fn 'a-combined-method) fn))
|
||||
(if (and (listp form)
|
||||
(eq (car form) 'call-method)
|
||||
(method-p (cadr form))
|
||||
(every #'method-p (caddr form)))
|
||||
;;
|
||||
;; The effective method is just a call to call-method. This opens up
|
||||
;; the possibility of just using the method function of the method as
|
||||
;; as the effective method function.
|
||||
;;
|
||||
;; But we have to be careful. If that method function will ask for
|
||||
;; the next methods we have to provide them. We do not look to see
|
||||
;; if there are next methods, we look at whether the method function
|
||||
;; asks about them. If it does, we must tell it whether there are
|
||||
;; or aren't to prevent the leaky next methods bug.
|
||||
;;
|
||||
(let* ((method-function (method-function (cadr form)))
|
||||
(arg-info (gf-arg-info generic-function))
|
||||
(metatypes (arg-info-metatypes arg-info))
|
||||
(applyp (arg-info-applyp arg-info)))
|
||||
(if (not (method-function-needs-next-methods-p method-function))
|
||||
method-function
|
||||
(let ((next-method-functions (mapcar #'method-function (caddr form))))
|
||||
(name-function
|
||||
(get-function `(lambda ,(make-dfun-lambda-list metatypes applyp)
|
||||
(let ((*next-methods* .next-method-functions.))
|
||||
,(make-dfun-call metatypes applyp '.method-function.)))
|
||||
#'default-test-converter ;This could be optimized by making
|
||||
;the interface from here to the
|
||||
;walker more clear so that the
|
||||
;form wouldn't get walked at all.
|
||||
#'(lambda (form)
|
||||
(if (memq form '(.next-method-functions. .method-function.))
|
||||
(values form (list form))
|
||||
form))
|
||||
#'(lambda (form)
|
||||
(cond ((eq form '.next-method-functions.)
|
||||
(list next-method-functions))
|
||||
((eq form '.method-function.)
|
||||
(list method-function)))))))))
|
||||
;;
|
||||
;; We have some sort of `real' effective method. Go off and get a
|
||||
;; compiled function for it. Most of the real hair here is done by
|
||||
;; the GET-FUNCTION mechanism.
|
||||
;;
|
||||
(name-function (make-effective-method-function-internal generic-function form)))))
|
||||
|
||||
(defvar *global-effective-method-gensyms* ())
|
||||
(defvar *rebound-effective-method-gensyms*)
|
||||
|
||||
(defun get-effective-method-gensym ()
|
||||
(or (pop *rebound-effective-method-gensyms*)
|
||||
(let ((new (make-symbol "EFFECTIVE-METHOD-GENSYM-")))
|
||||
(push new *global-effective-method-gensyms*)
|
||||
new)))
|
||||
|
||||
(eval-when (load)
|
||||
(let ((*rebound-effective-method-gensyms* ()))
|
||||
(dotimes (i 10) (get-effective-method-gensym))))
|
||||
|
||||
(defun make-effective-method-function-internal (generic-function effective-method)
|
||||
(let* ((*rebound-effective-method-gensyms* *global-effective-method-gensyms*)
|
||||
(arg-info (gf-arg-info generic-function))
|
||||
(metatypes (arg-info-metatypes arg-info))
|
||||
(applyp (arg-info-applyp arg-info)))
|
||||
(labels ((test-converter (form)
|
||||
(if (and (consp form) (eq (car form) 'call-method))
|
||||
'.call-method.
|
||||
(default-test-converter form)))
|
||||
(code-converter (form)
|
||||
(if (and (consp form) (eq (car form) 'call-method))
|
||||
;;
|
||||
;; We have a `call' to CALL-METHOD. There may or may not be next methods
|
||||
;; and the two cases are a little different. It controls how many gensyms
|
||||
;; we will generate.
|
||||
;;
|
||||
(let ((gensyms
|
||||
(if (cddr form)
|
||||
(list (get-effective-method-gensym)
|
||||
(get-effective-method-gensym))
|
||||
(list (get-effective-method-gensym)
|
||||
()))))
|
||||
(values `(let ((*next-methods* ,(cadr gensyms)))
|
||||
,(make-dfun-call metatypes applyp (car gensyms)))
|
||||
gensyms))
|
||||
(default-code-converter form)))
|
||||
(constant-converter (form)
|
||||
(if (and (consp form) (eq (car form) 'call-method))
|
||||
(if (cddr form)
|
||||
(list (check-for-make-method (cadr form))
|
||||
(mapcar #'check-for-make-method (caddr form)))
|
||||
(list (check-for-make-method (cadr form))
|
||||
()))
|
||||
(default-constant-converter form)))
|
||||
(check-for-make-method (effective-method)
|
||||
(cond ((method-p effective-method)
|
||||
(method-function effective-method))
|
||||
((and (listp effective-method)
|
||||
(eq (car effective-method) 'make-method))
|
||||
(make-effective-method-function generic-function
|
||||
(make-progn (cadr effective-method))))
|
||||
(t
|
||||
(error "Effective-method form is malformed.")))))
|
||||
(get-function `(lambda ,(make-dfun-lambda-list metatypes applyp) ,effective-method)
|
||||
#'test-converter
|
||||
#'code-converter
|
||||
#'constant-converter))))
|
||||
|
||||
|
||||
|
||||
(defvar *invalid-method-error*
|
||||
#'(lambda (&rest args)
|
||||
(declare (ignore args))
|
||||
(error
|
||||
"INVALID-METHOD-ERROR was called outside the dynamic scope~%~
|
||||
of a method combination function (inside the body of~%~
|
||||
DEFINE-METHOD-COMBINATION or a method on the generic~%~
|
||||
function COMPUTE-EFFECTIVE-METHOD).")))
|
||||
|
||||
(defvar *method-combination-error*
|
||||
#'(lambda (&rest args)
|
||||
(declare (ignore args))
|
||||
(error
|
||||
"METHOD-COMBINATION-ERROR was called outside the dynamic scope~%~
|
||||
of a method combination function (inside the body of~%~
|
||||
DEFINE-METHOD-COMBINATION or a method on the generic~%~
|
||||
function COMPUTE-EFFECTIVE-METHOD).")))
|
||||
|
||||
;(defmethod compute-effective-method :around ;issue with magic
|
||||
; ((generic-function generic-function) ;generic functions
|
||||
; (method-combination method-combination)
|
||||
; applicable-methods)
|
||||
; (declare (ignore applicable-methods))
|
||||
; (flet ((real-invalid-method-error (method format-string &rest args)
|
||||
; (declare (ignore method))
|
||||
; (apply #'error format-string args))
|
||||
; (real-method-combination-error (format-string &rest args)
|
||||
; (apply #'error format-string args)))
|
||||
; (let ((*invalid-method-error* #'real-invalid-method-error)
|
||||
; (*method-combination-error* #'real-method-combination-error))
|
||||
; (call-next-method))))
|
||||
|
||||
(defun invalid-method-error (&rest args)
|
||||
(declare (arglist method format-string &rest format-arguments))
|
||||
(apply *invalid-method-error* args))
|
||||
|
||||
(defun method-combination-error (&rest args)
|
||||
(declare (arglist format-string &rest format-arguments))
|
||||
(apply *method-combination-error* args))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; The STANDARD method combination type. This is coded by hand (rather than
|
||||
;;; with define-method-combination) for bootstrapping and efficiency reasons.
|
||||
;;; Note that the definition of the find-method-combination-method appears in
|
||||
;;; the file defcombin.lisp, this is because EQL methods can't appear in the
|
||||
;;; bootstrap.
|
||||
;;;
|
||||
;;; The defclass for the METHOD-COMBINATION and STANDARD-METHOD-COMBINATION
|
||||
;;; classes has to appear here for this reason. This code must conform to
|
||||
;;; the code in the file defcombin, look there for more details.
|
||||
;;;
|
||||
|
||||
(defclass method-combination () ())
|
||||
|
||||
(define-gf-predicate method-combination-p method-combination)
|
||||
|
||||
(defclass standard-method-combination
|
||||
(definition-source-mixin method-combination)
|
||||
((type :reader method-combination-type
|
||||
:initarg :type)
|
||||
(documentation :reader method-combination-documentation
|
||||
:initarg :documentation)
|
||||
(options :reader method-combination-options
|
||||
:initarg :options)))
|
||||
|
||||
(defmethod print-object ((mc method-combination) stream)
|
||||
(printing-random-thing (mc stream)
|
||||
(format stream
|
||||
"Method-Combination ~S ~S"
|
||||
(method-combination-type mc)
|
||||
(method-combination-options mc))))
|
||||
|
||||
(eval-when (load eval)
|
||||
(setq *standard-method-combination*
|
||||
(make-instance 'standard-method-combination
|
||||
:type 'standard
|
||||
:documentation "The standard method combination."
|
||||
:options ())))
|
||||
|
||||
;This definition appears in defcombin.lisp.
|
||||
;
|
||||
;(defmethod find-method-combination ((generic-function generic-function)
|
||||
; (type (eql 'standard))
|
||||
; options)
|
||||
; (when options
|
||||
; (method-combination-error
|
||||
; "The method combination type STANDARD accepts no options."))
|
||||
; *standard-method-combination*)
|
||||
|
||||
(defun make-call-methods (methods)
|
||||
(mapcar #'(lambda (method) `(call-method ,method ())) methods))
|
||||
|
||||
(defmethod compute-effective-method ((generic-function generic-function)
|
||||
(combin standard-method-combination)
|
||||
applicable-methods)
|
||||
(let ((before ())
|
||||
(primary ())
|
||||
(after ())
|
||||
(around ()))
|
||||
(dolist (m applicable-methods)
|
||||
(let ((qualifiers (method-qualifiers m)))
|
||||
(cond ((member ':before qualifiers) (push m before))
|
||||
((member ':after qualifiers) (push m after))
|
||||
((member ':around qualifiers) (push m around))
|
||||
(t
|
||||
(push m primary)))))
|
||||
(setq before (reverse before)
|
||||
after (reverse after)
|
||||
primary (reverse primary)
|
||||
around (reverse around))
|
||||
(cond ((null primary)
|
||||
`(error "No primary method for the generic function ~S." ',generic-function))
|
||||
((and (null before) (null after) (null around))
|
||||
;;
|
||||
;; By returning a single call-method `form' here we enable an important
|
||||
;; implementation-specific optimization.
|
||||
;;
|
||||
`(call-method ,(first primary) ,(rest primary)))
|
||||
(t
|
||||
(let ((main-effective-method
|
||||
(if (or before after (rest primary))
|
||||
`(multiple-value-prog1
|
||||
(progn ,@(make-call-methods before)
|
||||
(call-method ,(first primary) ,(rest primary)))
|
||||
,@(make-call-methods (reverse after)))
|
||||
`(call-method ,(first primary) ()))))
|
||||
(if around
|
||||
`(call-method ,(first around)
|
||||
(,@(rest around) (make-method ,main-effective-method)))
|
||||
main-effective-method))))))
|
||||
|
||||
@@ -1,11 +0,0 @@
|
||||
;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp; -*-
|
||||
;;;
|
||||
;;; *************************************************************************
|
||||
;;; Copyright (c) 1991 Venue
|
||||
;;; All rights reserved.
|
||||
;;; *************************************************************************
|
||||
;;;
|
||||
|
||||
(in-package 'clos)
|
||||
|
||||
()
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,271 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
|
||||
;;; compute-class-precedence-list Knuth section 2.2.3 has some interesting notes on this. What
|
||||
;;; appears here is basically the algorithm presented there. The key idea is that we use
|
||||
;;; class-precedence-description (CPD) structures to store the precedence information as we proceed.
|
||||
;;; The CPD structure for a class stores two critical pieces of information: - a count of the number
|
||||
;;; of "reasons" why the class can't go into the class precedence list yet. - a list of the
|
||||
;;; "reasons" this class prevents others from going in until after it
|
||||
|
||||
|
||||
|
||||
;;
|
||||
|
||||
|
||||
|
||||
;;; A "reason" is essentially a single local precedence constraint. If a constraint between two
|
||||
;;; classes arises more than once it generates more than one reason. This makes things simpler,
|
||||
;;; linear, and isn't a problem as long as we make sure to keep track of each instance of a
|
||||
;;; "reason". This code is divided into three phases. - the first phase simply generates the CPD's
|
||||
;;; for each of the class and its superclasses. The remainder of the code will manipulate these
|
||||
;;; CPDs rather than the class objects themselves. At the end of this pass, the CPD-SUPERS field of
|
||||
;;; a CPD is a list of the CPDs of the direct superclasses of the class. - the second phase folds
|
||||
;;; all the local constraints into the CPD structure. The CPD-COUNT of each CPD is built up, and
|
||||
;;; the CPD-AFTER fields are augmented to include precedence constraints from the CPD-SUPERS field
|
||||
;;; and from the order of classes in other CPD-SUPERS fields. After this phase, the CPD-AFTER field
|
||||
;;; of a class includes all the direct superclasses of the class plus any class that immediately
|
||||
;;; follows the class in the direct superclasses of another. There can be duplicates in this list.
|
||||
;;; The CPD-COUNT field is equal to the number of times this class appears in the CPD-AFTER field of
|
||||
;;; all the other CPDs. - In the third phase, classes are put into the precedence list one at a
|
||||
;;; time, with only those classes with a CPD-COUNT of 0 being candidates for insertion. When a
|
||||
;;; class is inserted , every CPD in its CPD-AFTER field has its count decremented. In the usual
|
||||
;;; case, there is only one candidate for insertion at any point. If there is more than one, the
|
||||
;;; specified tiebreaker rule is used to choose among them.
|
||||
|
||||
|
||||
(defmethod compute-class-precedence-list ((root std-class)
|
||||
direct-superclasses)
|
||||
(compute-std-cpl root direct-superclasses))
|
||||
|
||||
(defstruct (class-precedence-description (:conc-name nil)
|
||||
(:print-function (lambda (obj str depth)
|
||||
(declare (ignore depth))
|
||||
(format str "#<CPD ~S ~D>" (class-name (cpd-class obj))
|
||||
(cpd-count obj))))
|
||||
(:constructor make-cpd nil))
|
||||
(cpd-class nil)
|
||||
(cpd-supers nil)
|
||||
(cpd-after nil)
|
||||
(cpd-count 0))
|
||||
|
||||
(defun compute-std-cpl (class supers)
|
||||
(cond ((null supers)
|
||||
; First two branches of COND
|
||||
(list class))
|
||||
; are implementing the single
|
||||
((null (cdr supers))
|
||||
; inheritance optimization.
|
||||
(cons class (compute-std-cpl (car supers)
|
||||
(class-direct-superclasses (car supers)))))
|
||||
(t (multiple-value-bind (all-cpds nclasses)
|
||||
(compute-std-cpl-phase-1 class supers)
|
||||
(compute-std-cpl-phase-2 all-cpds)
|
||||
(compute-std-cpl-phase-3 class all-cpds nclasses)))))
|
||||
|
||||
(defvar *compute-std-cpl-class->entry-table-size* 60)
|
||||
|
||||
(defun compute-std-cpl-phase-1 (class supers)
|
||||
(let ((nclasses 0)
|
||||
(all-cpds nil)
|
||||
(table (make-hash-table :size *compute-std-cpl-class->entry-table-size* :test
|
||||
#'eq)))
|
||||
(labels ((get-cpd (c)
|
||||
(or (gethash c table)
|
||||
(setf (gethash c table)
|
||||
(make-cpd))))
|
||||
(walk (c supers)
|
||||
(if (forward-referenced-class-p c)
|
||||
(cpl-forward-referenced-class-error class c)
|
||||
(let ((cpd (get-cpd c)))
|
||||
(unless (cpd-class cpd)
|
||||
; If we have already done this class
|
||||
; before, we can quit.
|
||||
(setf (cpd-class cpd)
|
||||
c)
|
||||
(incf nclasses)
|
||||
(push cpd all-cpds)
|
||||
(setf (cpd-supers cpd)
|
||||
(mapcar #'get-cpd supers))
|
||||
(dolist (super supers)
|
||||
(walk super (class-direct-superclasses super))))))))
|
||||
(walk class supers)
|
||||
(values all-cpds nclasses))))
|
||||
|
||||
(defun compute-std-cpl-phase-2 (all-cpds)
|
||||
(dolist (cpd all-cpds)
|
||||
(let ((supers (cpd-supers cpd)))
|
||||
(when supers
|
||||
(setf (cpd-after cpd)
|
||||
(nconc (cpd-after cpd)
|
||||
supers))
|
||||
(incf (cpd-count (car supers))
|
||||
1)
|
||||
(do* ((t1 supers t2)
|
||||
(t2 (cdr t1)
|
||||
(cdr t1)))
|
||||
((null t2))
|
||||
(incf (cpd-count (car t2))
|
||||
2)
|
||||
(push (car t2)
|
||||
(cpd-after (car t1))))))))
|
||||
|
||||
(defun
|
||||
compute-std-cpl-phase-3
|
||||
(class all-cpds nclasses)
|
||||
(let ((candidates nil)
|
||||
(next-cpd nil)
|
||||
(rcpl nil))
|
||||
|
||||
;; We have to bootstrap the collection of those CPD's that have a zero count. Once we get
|
||||
;; going, we will maintain this list incrementally.
|
||||
(dolist (cpd all-cpds)
|
||||
(when (zerop (cpd-count cpd))
|
||||
(push cpd candidates)))
|
||||
(loop (when (null candidates)
|
||||
|
||||
;; If there are no candidates, and enough classes have been put into the precedence
|
||||
;; list, then we are all done. Otherwise it means there is a consistency problem.
|
||||
(if (zerop nclasses)
|
||||
(return (reverse rcpl))
|
||||
(cpl-inconsistent-error class all-cpds)))
|
||||
|
||||
;; Try to find the next class to put in from among the candidates. If there is only one,
|
||||
;; its easy, otherwise we have to use the famous RPG tiebreaker rule. There is some
|
||||
;; hair here to avoid having to call DELETE on the list of candidates. I dunno if its
|
||||
;; worth it but what the hell.
|
||||
(setq next-cpd
|
||||
(if (null (cdr candidates))
|
||||
(prog1 (car candidates)
|
||||
(setq candidates nil))
|
||||
(block tie-breaker
|
||||
(dolist (c rcpl)
|
||||
(let ((supers (class-direct-superclasses c)))
|
||||
(if (memq (cpd-class (car candidates))
|
||||
supers)
|
||||
(return-from tie-breaker (pop candidates))
|
||||
(do ((loc candidates (cdr loc)))
|
||||
((null (cdr loc)))
|
||||
(let ((cpd (cadr loc)))
|
||||
(when (memq (cpd-class cpd)
|
||||
supers)
|
||||
(setf (cdr loc)
|
||||
(cddr loc))
|
||||
(return-from tie-breaker cpd))))))))))
|
||||
(decf nclasses)
|
||||
(push (cpd-class next-cpd)
|
||||
rcpl)
|
||||
(dolist (after (cpd-after next-cpd))
|
||||
(when (zerop (decf (cpd-count after)))
|
||||
(push after candidates))))))
|
||||
|
||||
|
||||
;;; Support code for signalling nice error messages.
|
||||
|
||||
|
||||
(defun cpl-error (class format-string &rest format-args)
|
||||
(error "While computing the class precedence list of the class ~A.~%~A"
|
||||
(if (class-name class)
|
||||
(format nil "named ~S" (class-name class))
|
||||
class)
|
||||
(apply #'format nil format-string format-args)))
|
||||
|
||||
(defun cpl-forward-referenced-class-error (class forward-class)
|
||||
(flet ((class-or-name (class)
|
||||
(if (class-name class)
|
||||
(format nil "named ~S" (class-name class))
|
||||
class)))
|
||||
(let ((names (mapcar #'class-or-name (cdr (find-superclass-chain class forward-class))))
|
||||
)
|
||||
(cpl-error class
|
||||
"The class ~A is a forward referenced class.~@
|
||||
The class ~A is ~A." (class-or-name forward-class)
|
||||
(class-or-name forward-class)
|
||||
(if (null (cdr names))
|
||||
(format nil "a direct superclass of the class ~A" (class-or-name class))
|
||||
(format nil "reached from the class ~A by following~@
|
||||
the direct superclass chain through: ~A~
|
||||
~% ending at the class ~A" (class-or-name class)
|
||||
(format nil "~{~% the class ~A,~}" (butlast names))
|
||||
(car (last names))))))))
|
||||
|
||||
(defun find-superclass-chain (bottom top)
|
||||
(labels ((walk (c chain)
|
||||
(if (eq c top)
|
||||
(return-from find-superclass-chain (nreverse chain))
|
||||
(dolist (super (class-direct-superclasses c))
|
||||
(walk super (cons super chain))))))
|
||||
(walk bottom (list bottom))))
|
||||
|
||||
(defun cpl-inconsistent-error (class all-cpds)
|
||||
(let ((reasons (find-cycle-reasons all-cpds)))
|
||||
(cpl-error class "It is not possible to compute the class precedence list because~@
|
||||
there ~A in the local precedence relations.~@
|
||||
~A because:~{~% ~A~}." (if (cdr reasons)
|
||||
"are circularities"
|
||||
"is a circularity")
|
||||
(if (cdr reasons)
|
||||
"These arise"
|
||||
"This arises")
|
||||
(format-cycle-reasons (apply #'append reasons)))))
|
||||
|
||||
(defun format-cycle-reasons (reasons)
|
||||
(flet ((class-or-name (cpd)
|
||||
(let ((class (cpd-class cpd)))
|
||||
(if (class-name class)
|
||||
(format nil "named ~S" (class-name class))
|
||||
class))))
|
||||
(mapcar #'(lambda (reason)
|
||||
(ecase (caddr reason)
|
||||
(:super (format nil
|
||||
"the class ~A appears in the supers of the class ~A"
|
||||
(class-or-name (cadr reason))
|
||||
(class-or-name (car reason))))
|
||||
(:in-supers (format nil
|
||||
"the class ~A follows the class ~A in the supers of the class ~A"
|
||||
(class-or-name (cadr reason))
|
||||
(class-or-name (car reason))
|
||||
(class-or-name (cadddr reason))))))
|
||||
reasons)))
|
||||
|
||||
(defun find-cycle-reasons (all-cpds)
|
||||
(let ((been-here nil)
|
||||
; List of classes we have visited.
|
||||
(cycle-reasons nil))
|
||||
(labels ((chase (path)
|
||||
(if (memq (car path)
|
||||
(cdr path))
|
||||
(record-cycle (memq (car path)
|
||||
(nreverse path)))
|
||||
(unless (memq (car path)
|
||||
been-here)
|
||||
(push (car path)
|
||||
been-here)
|
||||
(dolist (after (cpd-after (car path)))
|
||||
(chase (cons after path))))))
|
||||
(record-cycle
|
||||
(cycle)
|
||||
(let ((reasons nil))
|
||||
(do* ((t1 cycle t2)
|
||||
(t2 (cdr t1)
|
||||
(cdr t1)))
|
||||
((null t2))
|
||||
(let ((c1 (car t1))
|
||||
(c2 (car t2)))
|
||||
(if (memq c2 (cpd-supers c1))
|
||||
(push (list c1 c2 :super)
|
||||
reasons)
|
||||
(dolist (cpd all-cpds)
|
||||
(when (memq c2 (memq c1 (cpd-supers cpd)))
|
||||
(return (push (list c1 c2 :in-supers cpd)
|
||||
reasons)))))))
|
||||
(push (nreverse reasons)
|
||||
cycle-reasons))))
|
||||
(dolist (cpd all-cpds)
|
||||
(unless (zerop (cpd-count cpd))
|
||||
(chase (list cpd))))
|
||||
cycle-reasons)))
|
||||
@@ -1,25 +0,0 @@
|
||||
;;;-*-Mode:LISP; Package: PCL; Base:10; Syntax:Common-lisp -*-
|
||||
;;;
|
||||
;;; *************************************************************************
|
||||
;;; Copyright (c) 1991 Venue
|
||||
;;; All rights reserved.
|
||||
;;; *************************************************************************
|
||||
;;;
|
||||
|
||||
(in-package 'clos)
|
||||
|
||||
;;;
|
||||
;;; The built-in method combination types as taken from page 1-31 of 88-002R.
|
||||
;;; Note that the STANDARD method combination type is defined by hand in the
|
||||
;;; file combin.lisp.
|
||||
;;;
|
||||
|
||||
(define-method-combination + :identity-with-one-argument t)
|
||||
(define-method-combination and :identity-with-one-argument t)
|
||||
(define-method-combination append :identity-with-one-argument nil)
|
||||
(define-method-combination list :identity-with-one-argument nil)
|
||||
(define-method-combination max :identity-with-one-argument t)
|
||||
(define-method-combination min :identity-with-one-argument t)
|
||||
(define-method-combination nconc :identity-with-one-argument t)
|
||||
(define-method-combination or :identity-with-one-argument t)
|
||||
(define-method-combination progn :identity-with-one-argument t)
|
||||
@@ -1,230 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
(in-package "CLOS")
|
||||
|
||||
;;; *************************************************************************
|
||||
|
||||
|
||||
|
||||
;;; MAKE-TOP-LEVEL-FORM is used by all PCL macros that appear `at top-level'. The original
|
||||
;;; motiviation for this function was to deal with the bug in the Genera compiler that prevents
|
||||
;;; lambda expressions in top-level forms other than DEFUN from being compiled. Now this function is
|
||||
;;; used to grab other functionality as well. This includes: - Preventing the grouping of top-level
|
||||
;;; forms. For example, a DEFCLASS followed by a DEFMETHOD may not want to be grouped into the same
|
||||
;;; top-level form. - Telling the programming environment what the pretty version of the name of
|
||||
;;; this form is. This is used by WARN.
|
||||
|
||||
|
||||
(defun make-top-level-form (name times form)
|
||||
(flet ((definition-name nil (if (and (listp name)
|
||||
(memq (car name)
|
||||
'(defmethod defclass class method
|
||||
method-combination)))
|
||||
(format nil "~A~{ ~S~}" (capitalize-words (car name)
|
||||
nil)
|
||||
(cdr name))
|
||||
(format nil "~S" name))))
|
||||
(definition-name)
|
||||
(make-progn `',name `(eval-when ,times ,form))))
|
||||
|
||||
(defun make-progn (&rest forms)
|
||||
(let ((progn-form nil))
|
||||
(labels ((collect-forms (forms)
|
||||
(unless (null forms)
|
||||
(collect-forms (cdr forms))
|
||||
(if (and (listp (car forms))
|
||||
(eq (caar forms)
|
||||
'progn))
|
||||
(collect-forms (cdar forms))
|
||||
(push (car forms)
|
||||
progn-form)))))
|
||||
(collect-forms forms)
|
||||
(cons 'progn progn-form))))
|
||||
|
||||
|
||||
;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is fixed. DEFCLASS always expands
|
||||
;;; into a call to LOAD-DEFCLASS. Until the meta- braid is set up, LOAD-DEFCLASS has a special
|
||||
;;; definition which simply collects all class definitions up, when the metabraid is initialized it
|
||||
;;; is done from those class definitions. After the metabraid has been setup, and the protocol for
|
||||
;;; defining classes has been defined, the real definition of LOAD-DEFCLASS is installed by the file
|
||||
;;; defclass.lisp
|
||||
|
||||
|
||||
(defmacro defclass (name direct-superclasses direct-slots &rest options)
|
||||
(declare (indentation 2 4 3 1))
|
||||
(expand-defclass name direct-superclasses direct-slots options))
|
||||
|
||||
(defun expand-defclass (name supers slots options)
|
||||
(setq supers (copy-tree supers)
|
||||
slots
|
||||
(copy-tree slots)
|
||||
options
|
||||
(copy-tree options))
|
||||
(let ((metaclass 'standard-class))
|
||||
(dolist (option options)
|
||||
(if (not (listp option))
|
||||
(error "~S is not a legal defclass option." option)
|
||||
(when (eq (car option)
|
||||
':metaclass)
|
||||
(unless (legal-class-name-p (cadr option))
|
||||
(error
|
||||
"The value of the :metaclass option (~S) is not a~%~
|
||||
legal class name." (cadr option)))
|
||||
(setq metaclass (cadr option))
|
||||
(setf options (remove option options))
|
||||
(return t))))
|
||||
(let ((*initfunctions* nil)
|
||||
(*accessors* nil))
|
||||
; Truly a crock, but we got to have it
|
||||
; to live nicely.
|
||||
(declare (special *initfunctions* *accessors*))
|
||||
(let ((canonical-slots (mapcar #'(lambda (spec)
|
||||
(canonicalize-slot-specification name spec))
|
||||
slots))
|
||||
(other-initargs (mapcar #'(lambda (option)
|
||||
(canonicalize-defclass-option name option))
|
||||
options)))
|
||||
(do-standard-defsetfs-for-defclass *accessors*)
|
||||
; (load-defclass name metaclass supers
|
||||
; canonical-slots (apply #'append
|
||||
; other-initargs) *accessors*)))))
|
||||
(make-top-level-form `(defclass ,name nil nil)
|
||||
*defclass-times*
|
||||
`(let ,(mapcar #'cdr *initfunctions*)
|
||||
(load-defclass ',name ',metaclass ',supers (list
|
||||
,@canonical-slots
|
||||
)
|
||||
(list ,@(apply #'append other-initargs))
|
||||
',*accessors*)))))))
|
||||
|
||||
(defun make-initfunction (initform)
|
||||
(declare (special *initfunctions*))
|
||||
(cond ((or (eq initform 't)
|
||||
(equal initform ''t))
|
||||
'#'true)
|
||||
((or (eq initform 'nil)
|
||||
(equal initform ''nil))
|
||||
'#'false)
|
||||
((or (eql initform '0)
|
||||
(equal initform ''0))
|
||||
'#'zero)
|
||||
(t (let ((entry (assoc initform *initfunctions* :test #'equal)))
|
||||
(unless entry
|
||||
(setq entry (list initform (gensym)
|
||||
`#'(lambda nil ,initform)))
|
||||
(push entry *initfunctions*))
|
||||
(cadr entry)))))
|
||||
|
||||
(defun canonicalize-slot-specification (class-name spec)
|
||||
(declare (special *accessors*))
|
||||
(cond ((and (symbolp spec)
|
||||
(not (keywordp spec))
|
||||
(not (memq spec '(t nil))))
|
||||
`'(:name ,spec))
|
||||
((not (consp spec))
|
||||
(error "~S is not a legal slot specification." spec))
|
||||
((null (cdr spec))
|
||||
`'(:name ,(car spec)))
|
||||
((null (cddr spec))
|
||||
(error
|
||||
"In DEFCLASS ~S, the slot specification ~S is obsolete.~%~
|
||||
Convert it to ~S" class-name spec (list (car spec)
|
||||
:initform
|
||||
(cadr spec))))
|
||||
(t (let* ((name (pop spec))
|
||||
(readers nil)
|
||||
(writers nil)
|
||||
(initargs nil)
|
||||
(unsupplied (list nil))
|
||||
(initform (getf spec :initform unsupplied)))
|
||||
(doplist (key val)
|
||||
spec
|
||||
(case key
|
||||
(:accessor
|
||||
(push val *accessors*)
|
||||
(push val readers)
|
||||
(push `(setf ,val)
|
||||
writers))
|
||||
(:reader (push val readers))
|
||||
(:writer (push val writers))
|
||||
(:initarg (push val initargs))))
|
||||
(loop (unless (remf spec :accessor)
|
||||
(return)))
|
||||
(loop (unless (remf spec :reader)
|
||||
(return)))
|
||||
(loop (unless (remf spec :writer)
|
||||
(return)))
|
||||
(loop (unless (remf spec :initarg)
|
||||
(return)))
|
||||
(setq spec `(:name ',name :readers ',readers
|
||||
:writers ',writers :initargs
|
||||
',initargs
|
||||
',spec))
|
||||
(if (eq initform unsupplied)
|
||||
`(list* ,@spec)
|
||||
`(list* :initfunction ,(make-initfunction initform)
|
||||
,@spec))))))
|
||||
|
||||
(defun canonicalize-defclass-option (class-name option)
|
||||
(declare (ignore class-name))
|
||||
(case (car option)
|
||||
(:default-initargs (let ((canonical nil))
|
||||
(let (key val (tail (cdr option)))
|
||||
(loop (when (null tail)
|
||||
(return nil))
|
||||
(setq key (pop tail)
|
||||
val
|
||||
(pop tail))
|
||||
(push ``(,',key ,,(make-initfunction val)
|
||||
,',val)
|
||||
canonical))
|
||||
`(':direct-default-initargs (list ,@(nreverse canonical))))))
|
||||
(otherwise `(',(car option)
|
||||
',(cdr option)))))
|
||||
|
||||
|
||||
;;; This is the early definition of load-defclass. It just collects up all the class definitions in
|
||||
;;; a list. Later, in the file braid1.lisp, these are actually defined. Each entry in
|
||||
;;; *early-class-definitions* is an early-class-definition.
|
||||
|
||||
|
||||
(defparameter *early-class-definitions* nil)
|
||||
|
||||
(defun make-early-class-definition (name source metaclass superclass-names canonical-slots
|
||||
other-initargs)
|
||||
(list 'early-class-definition name source metaclass superclass-names canonical-slots
|
||||
other-initargs))
|
||||
|
||||
(defun ecd-class-name (ecd)
|
||||
(nth 1 ecd))
|
||||
|
||||
(defun ecd-source (ecd)
|
||||
(nth 2 ecd))
|
||||
|
||||
(defun ecd-metaclass (ecd)
|
||||
(nth 3 ecd))
|
||||
|
||||
(defun ecd-superclass-names (ecd)
|
||||
(nth 4 ecd))
|
||||
|
||||
(defun ecd-canonical-slots (ecd)
|
||||
(nth 5 ecd))
|
||||
|
||||
(defun ecd-other-initargs (ecd)
|
||||
(nth 6 ecd))
|
||||
|
||||
(proclaim '(notinline load-defclass))
|
||||
|
||||
(defun load-defclass (name metaclass supers canonical-slots canonical-options accessor-names)
|
||||
(setq supers (copy-tree supers)
|
||||
canonical-slots
|
||||
(copy-tree canonical-slots)
|
||||
canonical-options
|
||||
(copy-tree canonical-options))
|
||||
(do-standard-defsetfs-for-defclass accessor-names)
|
||||
(let ((ecd (make-early-class-definition name (load-truename)
|
||||
metaclass supers canonical-slots (apply #'append canonical-options)))
|
||||
(existing (find name *early-class-definitions* :key #'ecd-class-name)))
|
||||
(setq *early-class-definitions* (cons ecd (remove existing *early-class-definitions*)))
|
||||
ecd))
|
||||
@@ -1,410 +0,0 @@
|
||||
;;;-*-Mode:LISP; Package: CLOS; Base:10; Syntax:Common-lisp -*-
|
||||
;;;
|
||||
;;; *************************************************************************
|
||||
;;; Copyright (c) 1991 Venue
|
||||
;;; All rights reserved.
|
||||
;;; *************************************************************************
|
||||
;;;
|
||||
|
||||
(in-package 'clos)
|
||||
|
||||
;;;
|
||||
;;; DEFINE-METHOD-COMBINATION
|
||||
;;;
|
||||
|
||||
(defmacro define-method-combination (&whole form &rest args)
|
||||
(declare (ignore args))
|
||||
(if (and (cddr form)
|
||||
(listp (caddr form)))
|
||||
(expand-long-defcombin form)
|
||||
(expand-short-defcombin form)))
|
||||
|
||||
|
||||
;;;
|
||||
;;; STANDARD method combination
|
||||
;;;
|
||||
;;; The STANDARD method combination type is implemented directly by the class
|
||||
;;; STANDARD-METHOD-COMBINATION. The method on COMPUTE-EFFECTIVE-METHOD does
|
||||
;;; standard method combination directly and is defined by hand in the file
|
||||
;;; combin.lisp. The method for FIND-METHOD-COMBINATION must appear in this
|
||||
;;; file for bootstrapping reasons.
|
||||
;;;
|
||||
;;; A commented out copy of this definition appears in combin.lisp.
|
||||
;;; If you change this definition here, be sure to change it there
|
||||
;;; also.
|
||||
;;;
|
||||
(defmethod find-method-combination ((generic-function generic-function)
|
||||
(type (eql 'standard))
|
||||
options)
|
||||
(when options
|
||||
(method-combination-error
|
||||
"The method combination type STANDARD accepts no options."))
|
||||
*standard-method-combination*)
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; short method combinations
|
||||
;;;
|
||||
;;; Short method combinations all follow the same rule for computing the
|
||||
;;; effective method. So, we just implement that rule once. Each short
|
||||
;;; method combination object just reads the parameters out of the object
|
||||
;;; and runs the same rule.
|
||||
;;;
|
||||
;;;
|
||||
(defclass short-method-combination (standard-method-combination)
|
||||
((operator
|
||||
:reader short-combination-operator
|
||||
:initarg :operator)
|
||||
(identity-with-one-argument
|
||||
:reader short-combination-identity-with-one-argument
|
||||
:initarg :identity-with-one-argument)))
|
||||
|
||||
(define-gf-predicate short-method-combination-p short-method-combination)
|
||||
|
||||
(defun expand-short-defcombin (whole)
|
||||
(let* ((type (cadr whole))
|
||||
(documentation
|
||||
(getf (cddr whole) :documentation ""))
|
||||
(identity-with-one-arg
|
||||
(getf (cddr whole) :identity-with-one-argument nil))
|
||||
(operator
|
||||
(getf (cddr whole) :operator type)))
|
||||
(make-top-level-form `(define-method-combination ,type)
|
||||
'(load eval)
|
||||
`(load-short-defcombin
|
||||
',type ',operator ',identity-with-one-arg ',documentation))))
|
||||
|
||||
(defun load-short-defcombin (type operator ioa doc)
|
||||
(let* ((truename (load-truename))
|
||||
(specializers
|
||||
(list (find-class 'generic-function)
|
||||
(make-instance 'eql-specializer :object type)
|
||||
*the-class-t*))
|
||||
(old-method
|
||||
(get-method #'find-method-combination () specializers nil))
|
||||
(new-method nil))
|
||||
(setq new-method
|
||||
(make-instance 'standard-method
|
||||
:qualifiers ()
|
||||
:specializers specializers
|
||||
:lambda-list '(generic-function type options)
|
||||
:function #'(lambda (gf type options)
|
||||
(declare (ignore gf))
|
||||
(do-short-method-combination
|
||||
type options operator ioa new-method doc))
|
||||
:definition-source `((define-method-combination ,type) ,truename)))
|
||||
(when old-method
|
||||
(remove-method #'find-method-combination old-method))
|
||||
(add-method #'find-method-combination new-method)))
|
||||
|
||||
(defun do-short-method-combination (type options operator ioa method doc)
|
||||
(cond ((null options) (setq options '(:most-specific-first)))
|
||||
((equal options '(:most-specific-first)))
|
||||
((equal options '(:most-specific-last)))
|
||||
(t
|
||||
(method-combination-error
|
||||
"Illegal options to a short method combination type.~%~
|
||||
The method combination type ~S accepts one option which~%~
|
||||
must be either :MOST-SPECIFIC-FIRST or :MOST-SPECIFIC-LAST."
|
||||
type)))
|
||||
(make-instance 'short-method-combination
|
||||
:type type
|
||||
:options options
|
||||
:operator operator
|
||||
:identity-with-one-argument ioa
|
||||
:definition-source method
|
||||
:documentation doc))
|
||||
|
||||
(defmethod compute-effective-method ((generic-function generic-function)
|
||||
(combin short-method-combination)
|
||||
applicable-methods)
|
||||
(let ((type (method-combination-type combin))
|
||||
(operator (short-combination-operator combin))
|
||||
(ioa (short-combination-identity-with-one-argument combin))
|
||||
(around ())
|
||||
(primary ()))
|
||||
(dolist (m applicable-methods)
|
||||
(let ((qualifiers (method-qualifiers m)))
|
||||
(flet ((lose (method why)
|
||||
(invalid-method-error
|
||||
method
|
||||
"The method ~S ~A.~%~
|
||||
The method combination type ~S was defined with the~%~
|
||||
short form of DEFINE-METHOD-COMBINATION and so requires~%~
|
||||
all methods have either the single qualifier ~S or the~%~
|
||||
single qualifier :AROUND."
|
||||
method why type type)))
|
||||
(cond ((null qualifiers)
|
||||
(lose m "has no qualifiers"))
|
||||
((cdr qualifiers)
|
||||
(lose m "has more than one qualifier"))
|
||||
((eq (car qualifiers) :around)
|
||||
(push m around))
|
||||
((eq (car qualifiers) type)
|
||||
(push m primary))
|
||||
(t
|
||||
(lose m "has an illegal qualifier"))))))
|
||||
(setq around (nreverse around)
|
||||
primary (nreverse primary))
|
||||
(let ((main-method
|
||||
(if (and (null (cdr primary))
|
||||
(not (null ioa)))
|
||||
`(call-method ,(car primary) ())
|
||||
`(,operator ,@(mapcar #'(lambda (m) `(call-method ,m ()))
|
||||
primary)))))
|
||||
(cond ((null primary)
|
||||
`(error "No ~S methods for the generic function ~S."
|
||||
',type ',generic-function))
|
||||
((null around) main-method)
|
||||
(t
|
||||
`(call-method ,(car around)
|
||||
(,@(cdr around) (make-method ,main-method))))))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; long method combinations
|
||||
;;;
|
||||
;;;
|
||||
|
||||
(defclass long-method-combination (standard-method-combination)
|
||||
((function :initarg :function
|
||||
:reader long-method-combination-function)))
|
||||
|
||||
(defun expand-long-defcombin (form)
|
||||
(let ((type (cadr form))
|
||||
(lambda-list (caddr form))
|
||||
(method-group-specifiers (cadddr form))
|
||||
(body (cddddr form))
|
||||
(arguments-option ())
|
||||
(gf-var nil))
|
||||
(when (and (consp (car body)) (eq (caar body) :arguments))
|
||||
(setq arguments-option (cdr (pop body))))
|
||||
(when (and (consp (car body)) (eq (caar body) :generic-function))
|
||||
(setq gf-var (cadr (pop body))))
|
||||
(multiple-value-bind (documentation function)
|
||||
(make-long-method-combination-function
|
||||
type lambda-list method-group-specifiers arguments-option gf-var
|
||||
body)
|
||||
(make-top-level-form `(define-method-combination ,type)
|
||||
'(load eval)
|
||||
`(load-long-defcombin ',type ',documentation #',function)))))
|
||||
|
||||
(defvar *long-method-combination-functions* (make-hash-table :test #'eq))
|
||||
|
||||
(defun load-long-defcombin (type doc function)
|
||||
(let* ((specializers
|
||||
(list (find-class 'generic-function)
|
||||
(make-instance 'eql-specializer :object type)
|
||||
*the-class-t*))
|
||||
(old-method
|
||||
(get-method #'find-method-combination () specializers nil))
|
||||
(new-method
|
||||
(make-instance 'standard-method
|
||||
:qualifiers ()
|
||||
:specializers specializers
|
||||
:lambda-list '(generic-function type options)
|
||||
:function #'(lambda (generic-function type options)
|
||||
(declare (ignore generic-function))
|
||||
(make-instance 'long-method-combination
|
||||
:type type
|
||||
:documentation doc
|
||||
:options options))
|
||||
:definition-source `((define-method-combination ,type)
|
||||
,(load-truename)))))
|
||||
(setf (gethash type *long-method-combination-functions*) function)
|
||||
(when old-method (remove-method #'find-method-combination old-method))
|
||||
(add-method #'find-method-combination new-method)))
|
||||
|
||||
(defmethod compute-effective-method ((generic-function generic-function)
|
||||
(combin long-method-combination)
|
||||
applicable-methods)
|
||||
(funcall (gethash (method-combination-type combin)
|
||||
*long-method-combination-functions*)
|
||||
generic-function
|
||||
combin
|
||||
applicable-methods))
|
||||
|
||||
;;;
|
||||
;;;
|
||||
;;;
|
||||
(defun make-long-method-combination-function
|
||||
(type ll method-group-specifiers arguments-option gf-var body)
|
||||
(declare (ignore type) (values documentation function))
|
||||
(multiple-value-bind (documentation declarations real-body)
|
||||
(extract-declarations body)
|
||||
|
||||
(let ((wrapped-body
|
||||
(wrap-method-group-specifier-bindings method-group-specifiers
|
||||
declarations
|
||||
real-body)))
|
||||
(when gf-var
|
||||
(push `(,gf-var .generic-function.) (cadr wrapped-body)))
|
||||
|
||||
(when arguments-option
|
||||
(setq wrapped-body (deal-with-arguments-option wrapped-body
|
||||
arguments-option)))
|
||||
|
||||
(when ll
|
||||
(setq wrapped-body
|
||||
`(apply #'(lambda ,ll ,wrapped-body)
|
||||
(method-combination-options .method-combination.))))
|
||||
|
||||
(values
|
||||
documentation
|
||||
`(lambda (.generic-function. .method-combination. .applicable-methods.)
|
||||
(progn .generic-function. .method-combination. .applicable-methods.)
|
||||
(block .long-method-combination-function. ,wrapped-body))))))
|
||||
;;
|
||||
;; parse-method-group-specifiers parse the method-group-specifiers
|
||||
;;
|
||||
|
||||
(defun wrap-method-group-specifier-bindings
|
||||
(method-group-specifiers declarations real-body)
|
||||
(with-gathering ((names (collecting))
|
||||
(specializer-caches (collecting))
|
||||
(cond-clauses (collecting))
|
||||
(required-checks (collecting))
|
||||
(order-cleanups (collecting)))
|
||||
(dolist (method-group-specifier method-group-specifiers)
|
||||
(multiple-value-bind (name tests description order required)
|
||||
(parse-method-group-specifier method-group-specifier)
|
||||
(declare (ignore description))
|
||||
(let ((specializer-cache (gensym)))
|
||||
(gather name names)
|
||||
(gather specializer-cache specializer-caches)
|
||||
(gather `((or ,@tests)
|
||||
(if (equal ,specializer-cache .specializers.)
|
||||
(return-from .long-method-combination-function.
|
||||
'(error "More than one method of type ~S ~
|
||||
with the same specializers."
|
||||
',name))
|
||||
(setq ,specializer-cache .specializers.))
|
||||
(push .method. ,name))
|
||||
cond-clauses)
|
||||
(when required
|
||||
(gather `(when (null ,name)
|
||||
(return-from .long-method-combination-function.
|
||||
'(error "No ~S methods." ',name)))
|
||||
required-checks))
|
||||
(loop (unless (and (constantp order)
|
||||
(neq order (setq order (eval order))))
|
||||
(return t)))
|
||||
(gather (cond ((eq order :most-specific-first)
|
||||
`(setq ,name (nreverse ,name)))
|
||||
((eq order :most-specific-last) ())
|
||||
(t
|
||||
`(ecase ,order
|
||||
(:most-specific-first
|
||||
(setq ,name (nreverse ,name)))
|
||||
(:most-specific-last))))
|
||||
order-cleanups))))
|
||||
`(let (,@names ,@specializer-caches)
|
||||
,@declarations
|
||||
(dolist (.method. .applicable-methods.)
|
||||
(let ((.qualifiers. (method-qualifiers .method.))
|
||||
(.specializers. (method-specializers .method.)))
|
||||
(progn .qualifiers. .specializers.)
|
||||
(cond ,@cond-clauses)))
|
||||
,@required-checks
|
||||
,@order-cleanups
|
||||
,@real-body)))
|
||||
|
||||
(defun parse-method-group-specifier (method-group-specifier)
|
||||
(declare (values name tests description order required))
|
||||
(let* ((name (pop method-group-specifier))
|
||||
(patterns ())
|
||||
(tests
|
||||
(gathering1 (collecting)
|
||||
(block collect-tests
|
||||
(loop
|
||||
(if (or (null method-group-specifier)
|
||||
(memq (car method-group-specifier)
|
||||
'(:description :order :required)))
|
||||
(return-from collect-tests t)
|
||||
(let ((pattern (pop method-group-specifier)))
|
||||
(push pattern patterns)
|
||||
(gather1 (parse-qualifier-pattern name pattern)))))))))
|
||||
(values name
|
||||
tests
|
||||
(getf method-group-specifier :description
|
||||
(make-default-method-group-description patterns))
|
||||
(getf method-group-specifier :order :most-specific-first)
|
||||
(getf method-group-specifier :required nil))))
|
||||
|
||||
(defun parse-qualifier-pattern (name pattern)
|
||||
(cond ((eq pattern '()) `(null .qualifiers.))
|
||||
((eq pattern '*) 't)
|
||||
((symbolp pattern) `(,pattern .qualifiers.))
|
||||
((listp pattern) `(qualifier-check-runtime ',pattern .qualifiers.))
|
||||
(t (error "In the method group specifier ~S,~%~
|
||||
~S isn't a valid qualifier pattern."
|
||||
name pattern))))
|
||||
|
||||
(defun qualifier-check-runtime (pattern qualifiers)
|
||||
(loop (cond ((and (null pattern) (null qualifiers))
|
||||
(return t))
|
||||
((eq pattern '*) (return t))
|
||||
((and pattern qualifiers (eq (car pattern) (car qualifiers)))
|
||||
(pop pattern)
|
||||
(pop qualifiers))
|
||||
(t (return nil)))))
|
||||
|
||||
(defun make-default-method-group-description (patterns)
|
||||
(if (cdr patterns)
|
||||
(format nil
|
||||
"methods matching one of the patterns: ~{~S, ~} ~S"
|
||||
(butlast patterns) (car (last patterns)))
|
||||
(format nil
|
||||
"methods matching the pattern: ~S"
|
||||
(car patterns))))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; This baby is a complete mess. I can't believe we put it in this
|
||||
;;; way. No doubt this is a large part of what drives MLY crazy.
|
||||
;;;
|
||||
;;; At runtime (when the effective-method is run), we bind an intercept
|
||||
;;; lambda-list to the arguments to the generic function.
|
||||
;;;
|
||||
;;; At compute-effective-method time, the symbols in the :arguments
|
||||
;;; option are bound to the symbols in the intercept lambda list.
|
||||
;;;
|
||||
(defun deal-with-arguments-option (wrapped-body arguments-option)
|
||||
(let* ((intercept-lambda-list
|
||||
(gathering1 (collecting)
|
||||
(dolist (arg arguments-option)
|
||||
(if (memq arg lambda-list-keywords)
|
||||
(gather1 arg)
|
||||
(gather1 (gensym))))))
|
||||
(intercept-rebindings
|
||||
(gathering1 (collecting)
|
||||
(iterate ((arg (list-elements arguments-option))
|
||||
(int (list-elements intercept-lambda-list)))
|
||||
(unless (memq arg lambda-list-keywords)
|
||||
(gather1 `(,arg ',int)))))))
|
||||
;;
|
||||
;;
|
||||
(setf (cadr wrapped-body)
|
||||
(append intercept-rebindings (cadr wrapped-body)))
|
||||
;;
|
||||
;; Be sure to fill out the intercept lambda list so that it can
|
||||
;; be too short if it wants to.
|
||||
;;
|
||||
(cond ((memq '&rest intercept-lambda-list))
|
||||
((memq '&allow-other-keys intercept-lambda-list))
|
||||
((memq '&key intercept-lambda-list)
|
||||
(setq intercept-lambda-list
|
||||
(append intercept-lambda-list '(&allow-other-keys))))
|
||||
(t
|
||||
(setq intercept-lambda-list
|
||||
(append intercept-lambda-list '(&rest .ignore.)))))
|
||||
|
||||
`(let ((inner-result. ,wrapped-body))
|
||||
`(apply #'(lambda ,',intercept-lambda-list
|
||||
,,(when (memq '.ignore. intercept-lambda-list)
|
||||
''(declare (ignore .ignore.)))
|
||||
,inner-result.)
|
||||
.combined-method-args.))))
|
||||
|
||||
@@ -1,570 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
(eval-when (compile load eval)
|
||||
(defvar *defclass-times* '(load eval compile)) ;Probably have to change this
|
||||
;if you use defconstructor.
|
||||
(defvar *defmethod-times* '(load eval compile))
|
||||
(defvar *defgeneric-times* '(load eval compile))
|
||||
)
|
||||
|
||||
|
||||
;;; Convert a function name to its standard setf function name. We have to do this hack because not
|
||||
;;; all Common Lisps have yet converted to having setf function specs. In a port that does have setf
|
||||
;;; function specs you can use those just by making the obvious simple changes to these functions.
|
||||
;;; The rest of CLOS believes that there are function names like (SETF <foo>), this is the only place
|
||||
;;; that knows about this hack.
|
||||
|
||||
|
||||
(eval-when (compile load eval)
|
||||
(defvar *setf-function-names* (make-hash-table :size 200 :test #'eq))
|
||||
(defun get-setf-function-name (name)
|
||||
(or (gethash name *setf-function-names*)
|
||||
(setf (gethash name *setf-function-names*)
|
||||
(intern (format nil
|
||||
"SETF ~A ~A"
|
||||
(package-name (symbol-package name))
|
||||
(symbol-name name))
|
||||
*the-clos-package*))))
|
||||
|
||||
;;;
|
||||
;;; Call this to define a setf macro for a function with the same behavior as
|
||||
;;; specified by the SETF function cleanup proposal. Specifically, this will
|
||||
;;; cause: (SETF (FOO a b) x) to expand to (|SETF FOO| x a b).
|
||||
;;;
|
||||
;;; do-standard-defsetf A macro interface for use at top level
|
||||
;;; in files. Unfortunately, users may
|
||||
;;; have to use this for a while.
|
||||
;;;
|
||||
;;; do-standard-defsetfs-for-defclass A special version called by defclass.
|
||||
;;;
|
||||
;;; do-standard-defsetf-1 A functional interface called by the
|
||||
;;; above, defmethod and defgeneric.
|
||||
;;; Since this is all a crock anyways,
|
||||
;;; users are free to call this as well.
|
||||
;;;
|
||||
(defmacro do-standard-defsetf (&rest function-names)
|
||||
`(eval-when (compile load eval)
|
||||
(dolist (fn-name ',function-names) (do-standard-defsetf-1 fn-name))))
|
||||
|
||||
(defun do-standard-defsetfs-for-defclass (accessors)
|
||||
(dolist (name accessors) (do-standard-defsetf-1 name)))
|
||||
|
||||
(defun do-standard-defsetf-1 (function-name)
|
||||
(unless (setfboundp function-name)
|
||||
(let* ((setf-function-name (get-setf-function-name function-name)))
|
||||
|
||||
(flet ((setf-expander (body env)
|
||||
(declare (ignore env))
|
||||
(let ((temps
|
||||
(mapcar #'(lambda (x) (declare (ignore x)) (gensym))
|
||||
(cdr body)))
|
||||
(forms (cdr body))
|
||||
(vars (list (gensym))))
|
||||
(values temps
|
||||
forms
|
||||
vars
|
||||
`(,setf-function-name ,@vars ,@temps)
|
||||
`(,function-name ,@temps)))))
|
||||
(let ((setf-method-expander (intern (concatenate 'string
|
||||
(symbol-name function-name)
|
||||
"-setf-expander")
|
||||
(symbol-package function-name))))
|
||||
(setf (get function-name :setf-method-expander) setf-method-expander
|
||||
(symbol-function setf-method-expander) #'setf-expander)))
|
||||
|
||||
)))
|
||||
(defun setfboundp (symbol)
|
||||
(or (get symbol :setf-inverse)
|
||||
(get symbol 'il:setf-inverse)
|
||||
(get symbol 'il:setfn)
|
||||
(get symbol :shared-setf-inverse)
|
||||
(get symbol :setf-method-expander)
|
||||
(get symbol 'il:setf-method-expander)))
|
||||
)
|
||||
|
||||
; eval-when
|
||||
|
||||
|
||||
|
||||
;;; CLOS, like user code, must endure the fact that we don't have a properly working setf. Many
|
||||
;;; things work because they get mentioned by a defclass or defmethod before they are used, but
|
||||
;;; others have to be done by hand.
|
||||
|
||||
|
||||
(do-standard-defsetf
|
||||
class-wrapper ; ***
|
||||
generic-function-name
|
||||
method-function-plist
|
||||
method-function-get
|
||||
gdefinition
|
||||
slot-value-using-class)
|
||||
|
||||
(defsetf slot-value set-slot-value)
|
||||
|
||||
|
||||
;;; This is like fdefinition on the Lispm. If Common Lisp had something like function specs I
|
||||
;;; wouldn't need this. On the other hand, I don't like the way this really works so maybe function
|
||||
;;; specs aren't really right either? I also don't understand the real implications of a Lisp-1 on
|
||||
;;; this sort of thing. Certainly some of the lossage in all of this is because these SPECs name
|
||||
;;; global definitions. Note that this implementation is set up so that an implementation which has
|
||||
;;; a 'real' function spec mechanism can use that instead and in that way get rid of setf generic
|
||||
;;; function names.
|
||||
|
||||
|
||||
(defmacro parse-gspec (spec (non-setf-var . non-setf-case)
|
||||
(setf-var . setf-case))
|
||||
(once-only (spec)
|
||||
`(cond ((symbolp ,spec)
|
||||
(let ((,non-setf-var ,spec))
|
||||
,@non-setf-case))
|
||||
((and (listp ,spec)
|
||||
(eq (car ,spec)
|
||||
'setf)
|
||||
(symbolp (cadr ,spec)))
|
||||
(let ((,setf-var (cadr ,spec)))
|
||||
,@setf-case))
|
||||
(t (error "Can't understand ~S as a generic function specifier.~%~
|
||||
It must be either a symbol which can name a function or~%~
|
||||
a list like ~S, where the car is the symbol ~S and the cadr~%~
|
||||
is a symbol which can name a generic function." ,spec '(setf <foo>)
|
||||
'setf)))))
|
||||
|
||||
|
||||
;;; If symbol names a function which is traced or advised, return the unadvised, traced etc.
|
||||
;;; definition. This lets me get at the generic function object even when it is traced.
|
||||
|
||||
|
||||
(defun unencapsulated-fdefinition (symbol)
|
||||
(il:virginfn symbol))
|
||||
|
||||
|
||||
;;; If symbol names a function which is traced or advised, redefine the `real' definition without
|
||||
;;; affecting the advise.
|
||||
|
||||
|
||||
(defun fdefine-carefully (symbol new-definition)
|
||||
(let ((advisedp (member symbol il:advisedfns :test #'eq))
|
||||
(brokenp (member symbol il:brokenfns :test #'eq)))
|
||||
|
||||
;; In XeroxLisp (late of envos) tracing is implemented as a special case of "breaking".
|
||||
;; Advising, however, is treated specially.
|
||||
(xcl:unadvise-function symbol :no-error t)
|
||||
(xcl:unbreak-function symbol :no-error t)
|
||||
(setf (symbol-function symbol)
|
||||
new-definition)
|
||||
(when brokenp (xcl:rebreak-function symbol))
|
||||
(when advisedp (xcl:readvise-function symbol)))
|
||||
new-definition)
|
||||
|
||||
(defun gboundp (spec)
|
||||
(parse-gspec spec (name (fboundp name))
|
||||
(name (fboundp (get-setf-function-name name)))))
|
||||
|
||||
(defun gmakunbound (spec)
|
||||
(parse-gspec spec (name (fmakunbound name))
|
||||
(name (fmakunbound (get-setf-function-name name)))))
|
||||
|
||||
(defun gdefinition (spec)
|
||||
(parse-gspec spec (name (or (macro-function name)
|
||||
; ??
|
||||
(unencapsulated-fdefinition name)))
|
||||
(name (unencapsulated-fdefinition (get-setf-function-name name)))))
|
||||
|
||||
(defun SETF\ CLOS\ GDEFINITION (new-value spec)
|
||||
(parse-gspec spec (name (fdefine-carefully name new-value))
|
||||
(name (fdefine-carefully (get-setf-function-name name)
|
||||
new-value))))
|
||||
|
||||
|
||||
;;; These functions are a pale imitiation of their namesake. They accept class objects or types
|
||||
;;; where they should.
|
||||
|
||||
|
||||
(defun *typep (object type)
|
||||
(if (classp type)
|
||||
(let ((class (class-of object)))
|
||||
(if class
|
||||
(memq type (class-precedence-list class))
|
||||
nil))
|
||||
(let ((class (find-class type nil)))
|
||||
(if class
|
||||
(*typep object class)
|
||||
(typep object type)))))
|
||||
|
||||
(defun *subtypep (type1 type2)
|
||||
(let ((c1 (if (classp type1)
|
||||
type1
|
||||
(find-class type1 nil)))
|
||||
(c2 (if (classp type2)
|
||||
type2
|
||||
(find-class type2 nil))))
|
||||
(if (and c1 c2)
|
||||
(memq c2 (class-precedence-list c1))
|
||||
(if (or c1 c2)
|
||||
nil
|
||||
; This isn't quite right, but...
|
||||
(subtypep type1 type2)))))
|
||||
|
||||
(defun do-satisfies-deftype (name predicate)
|
||||
(let* ((specifier `(satisfies ,predicate))
|
||||
(expand-fn #'(lambda (&rest ignore)
|
||||
(declare (ignore ignore))
|
||||
specifier)))
|
||||
|
||||
;; Specific ports can insert their own way of doing this. Many ports may find the
|
||||
;; expand-fn defined above useful.
|
||||
(or
|
||||
;; This is the default for ports for which we don't know any better. Note that for
|
||||
;; most ports, providing this definition should just speed up class definition. It
|
||||
;; shouldn't have an effect on performance of most user code.
|
||||
(eval `(deftype ,name nil '(satisfies ,predicate))))))
|
||||
|
||||
(defun make-type-predicate-name (name)
|
||||
(intern (format nil "TYPE-PREDICATE ~A ~A" (package-name (symbol-package name))
|
||||
(symbol-name name))
|
||||
*the-clos-package*))
|
||||
|
||||
(proclaim '(special *the-class-t* *the-class-vector* *the-class-symbol* *the-class-string*
|
||||
*the-class-sequence* *the-class-rational* *the-class-ratio* *the-class-number*
|
||||
*the-class-null* *the-class-list* *the-class-integer* *the-class-float*
|
||||
*the-class-cons* *the-class-complex* *the-class-character* *the-class-bit-vector*
|
||||
*the-class-array* *the-class-standard-object* *the-class-class* *the-class-method*
|
||||
*the-class-generic-function* *the-class-standard-class* *the-class-standard-method*
|
||||
*the-class-standard-generic-function*
|
||||
*the-class-standard-effective-slot-definition* *the-eslotd-standard-class-slots*))
|
||||
|
||||
(proclaim '(special *the-wrapper-of-t* *the-wrapper-of-vector* *the-wrapper-of-symbol*
|
||||
*the-wrapper-of-string* *the-wrapper-of-sequence* *the-wrapper-of-rational*
|
||||
*the-wrapper-of-ratio* *the-wrapper-of-number* *the-wrapper-of-null*
|
||||
*the-wrapper-of-list* *the-wrapper-of-integer* *the-wrapper-of-float*
|
||||
*the-wrapper-of-cons* *the-wrapper-of-complex* *the-wrapper-of-character*
|
||||
*the-wrapper-of-bit-vector* *the-wrapper-of-array*))
|
||||
|
||||
(defvar *built-in-class-symbols* nil)
|
||||
|
||||
(defvar *built-in-wrapper-symbols* nil)
|
||||
|
||||
(defun get-built-in-class-symbol (class-name)
|
||||
(or (cadr (assq class-name *built-in-class-symbols*))
|
||||
(let ((symbol (intern (format nil "*THE-CLASS-~A*" (symbol-name class-name))
|
||||
*the-clos-package*)))
|
||||
(push (list class-name symbol)
|
||||
*built-in-class-symbols*)
|
||||
symbol)))
|
||||
|
||||
(defun get-built-in-wrapper-symbol (class-name)
|
||||
(or (cadr (assq class-name *built-in-wrapper-symbols*))
|
||||
(let ((symbol (intern (format nil "*THE-WRAPPER-OF-~A*" (symbol-name class-name))
|
||||
*the-clos-package*)))
|
||||
(push (list class-name symbol)
|
||||
*built-in-wrapper-symbols*)
|
||||
symbol)))
|
||||
|
||||
(pushnew 'class *variable-declarations*)
|
||||
|
||||
(pushnew 'variable-rebinding *variable-declarations*)
|
||||
|
||||
(defun variable-class (var env)
|
||||
(caddr (variable-declaration 'class var env)))
|
||||
|
||||
(defvar *boot-state* nil)
|
||||
; NIL EARLY BRAID COMPLETE
|
||||
|
||||
|
||||
(eval-when (load eval)
|
||||
(when (eq *boot-state* 'complete)
|
||||
(error "Trying to load (or compile) CLOS in an environment in which it~%~
|
||||
has already been loaded. This doesn't work, you will have to~%~
|
||||
get a fresh lisp (reboot) and then load CLOS."))
|
||||
(when *boot-state* (cerror "Try loading (or compiling) CLOS anyways." "Trying to load (or compile) CLOS in an environment in which it~%~
|
||||
has already been partially loaded. This may not work, you may~%~
|
||||
need to get a fresh lisp (reboot) and then load CLOS.")))
|
||||
|
||||
|
||||
;;; This is used by combined methods to communicate the next methods to the methods they call. This
|
||||
;;; variable is captured by a lexical variable of the methods to give it the proper lexical scope.
|
||||
|
||||
|
||||
(defvar *next-methods* nil)
|
||||
|
||||
(defvar *not-an-eql-specializer* '(not-an-eql-specializer))
|
||||
|
||||
(defvar *umi-gfs*)
|
||||
|
||||
(defvar *umi-complete-classes*)
|
||||
|
||||
(defvar *umi-reorder*)
|
||||
|
||||
(defvar *invalidate-discriminating-function-force-p* nil)
|
||||
|
||||
(defvar *invalid-dfuns-on-stack* nil)
|
||||
|
||||
(defvar *standard-method-combination*)
|
||||
|
||||
(defvar *slotd-unsupplied* (list '*slotd-unsupplied*))
|
||||
|
||||
; ***
|
||||
|
||||
|
||||
(defmacro define-gf-predicate (predicate &rest classes)
|
||||
`(progn (defmethod ,predicate ((x t))
|
||||
nil)
|
||||
,@(mapcar #'(lambda (c)
|
||||
`(defmethod ,predicate ((x ,c))
|
||||
t))
|
||||
classes)))
|
||||
|
||||
(defmacro plist-value (object name)
|
||||
`(with-slots (plist)
|
||||
,object
|
||||
(getf plist ,name)))
|
||||
|
||||
(defsetf plist-value (object name)
|
||||
(new-value)
|
||||
(once-only (new-value)
|
||||
`(with-slots (plist)
|
||||
,object
|
||||
(if ,new-value
|
||||
(setf (getf plist ,name)
|
||||
,new-value)
|
||||
(progn (remf plist ,name)
|
||||
nil)))))
|
||||
|
||||
(defvar *built-in-classes*
|
||||
|
||||
;; name supers subs cdr of cpl
|
||||
'((number (t) (complex float rational)
|
||||
(t))
|
||||
(complex (number)
|
||||
nil
|
||||
(number t))
|
||||
(float (number)
|
||||
nil
|
||||
(number t))
|
||||
(rational (number)
|
||||
(integer ratio)
|
||||
(number t))
|
||||
(integer (rational)
|
||||
nil
|
||||
(rational number t))
|
||||
(ratio (rational)
|
||||
nil
|
||||
(rational number t))
|
||||
(sequence (t)
|
||||
(list vector)
|
||||
(t))
|
||||
(list (sequence)
|
||||
(cons null)
|
||||
(sequence t))
|
||||
(cons (list)
|
||||
nil
|
||||
(list sequence t))
|
||||
(array (t)
|
||||
(vector)
|
||||
(t))
|
||||
(vector (array sequence)
|
||||
(string bit-vector)
|
||||
(array sequence t))
|
||||
(string (vector)
|
||||
nil
|
||||
(vector array sequence t))
|
||||
(bit-vector (vector)
|
||||
nil
|
||||
(vector array sequence t))
|
||||
(character (t)
|
||||
nil
|
||||
(t))
|
||||
(symbol (t)
|
||||
(null)
|
||||
(t))
|
||||
(null (symbol)
|
||||
nil
|
||||
(symbol list sequence t))))
|
||||
|
||||
|
||||
;;; The classes that define the kernel of the metabraid.
|
||||
|
||||
|
||||
(defclass t nil nil (:metaclass built-in-class))
|
||||
|
||||
(defclass standard-object (t)
|
||||
nil)
|
||||
|
||||
(defclass metaobject (standard-object)
|
||||
nil)
|
||||
|
||||
(defclass specializer (metaobject)
|
||||
nil)
|
||||
|
||||
(defclass definition-source-mixin (standard-object)
|
||||
((source :initform (load-truename)
|
||||
:reader definition-source :initarg :definition-source)))
|
||||
|
||||
(defclass plist-mixin (standard-object)
|
||||
((plist :initform nil)))
|
||||
|
||||
(defclass documentation-mixin (plist-mixin)
|
||||
nil)
|
||||
|
||||
(defclass dependent-update-mixin (plist-mixin)
|
||||
nil)
|
||||
|
||||
|
||||
;;; The class CLASS is a specified basic class. It is the common superclass of any kind of class.
|
||||
;;; That is any class that can be a metaclass must have the class CLASS in its class precedence
|
||||
;;; list.
|
||||
|
||||
|
||||
(defclass class (documentation-mixin dependent-update-mixin definition-source-mixin specializer)
|
||||
((name :initform nil :initarg :name :accessor class-name)
|
||||
(direct-superclasses :initform nil :reader class-direct-superclasses)
|
||||
(direct-subclasses :initform nil :reader class-direct-subclasses)
|
||||
(direct-methods :initform (cons nil nil))))
|
||||
|
||||
|
||||
;;; The class CLOS-CLASS is an implementation-specific common superclass of all specified subclasses
|
||||
;;; of the class CLASS.
|
||||
|
||||
|
||||
(defclass clos-class (class)
|
||||
((class-precedence-list :initform nil)
|
||||
(wrapper :initform nil)))
|
||||
|
||||
|
||||
;;; The class STD-CLASS is an implementation-specific common superclass of the classes
|
||||
;;; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS.
|
||||
|
||||
|
||||
(defclass std-class (clos-class)
|
||||
((direct-slots :initform nil :accessor class-direct-slots)
|
||||
(slots :initform nil :accessor class-slots)
|
||||
(no-of-instance-slots ; *** MOVE TO WRAPPER ***
|
||||
:initform 0 :accessor class-no-of-instance-slots)
|
||||
(prototype :initform nil)))
|
||||
|
||||
(defclass standard-class (std-class)
|
||||
nil)
|
||||
|
||||
(defclass funcallable-standard-class (std-class)
|
||||
nil)
|
||||
|
||||
(defclass forward-referenced-class (clos-class)
|
||||
nil)
|
||||
|
||||
(defclass built-in-class (clos-class)
|
||||
nil)
|
||||
|
||||
|
||||
;;; Slot definitions. Note that throughout CLOS, "SLOT-DEFINITION" is abbreviated as "SLOTD".
|
||||
|
||||
|
||||
(defclass slot-definition (metaobject)
|
||||
nil)
|
||||
|
||||
(defclass direct-slot-definition (slot-definition)
|
||||
nil)
|
||||
|
||||
(defclass effective-slot-definition (slot-definition)
|
||||
nil)
|
||||
;
|
||||
(defclass standard-slot-definition (slot-definition)
|
||||
((name :initform nil :accessor slotd-name)
|
||||
(initform :initform *slotd-unsupplied* :accessor slotd-initform)
|
||||
(initfunction :initform *slotd-unsupplied* :accessor slotd-initfunction)
|
||||
(readers :initform nil :accessor slotd-readers)
|
||||
(writers :initform nil :accessor slotd-writers)
|
||||
(initargs :initform nil :accessor slotd-initargs)
|
||||
(allocation :initform nil :accessor slotd-allocation)
|
||||
(type :initform nil :accessor slotd-type)
|
||||
(documentation :initform "" :initarg :documentation)
|
||||
(class :initform nil :accessor slotd-class)
|
||||
(instance-index :initform nil :accessor slotd-instance-index)))
|
||||
|
||||
(defclass standard-direct-slot-definition (standard-slot-definition direct-slot-definition)
|
||||
nil)
|
||||
|
||||
; Adding slots here may involve extra
|
||||
; work to the code in braid.lisp
|
||||
|
||||
|
||||
(defclass standard-effective-slot-definition (standard-slot-definition effective-slot-definition)
|
||||
nil)
|
||||
|
||||
; Adding slots here may involve extra
|
||||
; work to the code in braid.lisp
|
||||
|
||||
|
||||
(defclass eql-specializer (specializer)
|
||||
((object :initarg :object :reader eql-specializer-object)))
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
(defmacro dolist-carefully ((var list improper-list-handler)
|
||||
&body body)
|
||||
`(let ((,var nil)
|
||||
(.dolist-carefully. ,list))
|
||||
(loop (when (null .dolist-carefully.)
|
||||
(return nil))
|
||||
(if (consp .dolist-carefully.)
|
||||
(progn (setq ,var (pop .dolist-carefully.))
|
||||
,@body)
|
||||
(,improper-list-handler)))))
|
||||
|
||||
(defun legal-std-documentation-p (x)
|
||||
(if (or (null x)
|
||||
(stringp x))
|
||||
t
|
||||
"a string or NULL"))
|
||||
|
||||
(defun legal-std-lambda-list-p (x)
|
||||
(declare (ignore x))
|
||||
t)
|
||||
|
||||
(defun legal-std-method-function-p (x)
|
||||
(if (functionp x)
|
||||
t
|
||||
"a function"))
|
||||
|
||||
(defun legal-std-qualifiers-p (x)
|
||||
(flet ((improper-list nil (return-from legal-std-qualifiers-p "Is not a proper list.")))
|
||||
(dolist-carefully (q x improper-list)
|
||||
(let ((ok (legal-std-qualifier-p q)))
|
||||
(unless (eq ok t)
|
||||
(return-from legal-std-qualifiers-p (format nil "Contains ~S which ~A" q
|
||||
ok)))))
|
||||
t))
|
||||
|
||||
(defun legal-std-qualifier-p (x)
|
||||
(if (and x (atom x))
|
||||
t
|
||||
"is not a non-null atom"))
|
||||
|
||||
(defun legal-std-slot-name-p (x)
|
||||
(cond ((not (symbolp x))
|
||||
"is not a symbol and so cannot be bound")
|
||||
((keywordp x)
|
||||
"is a keyword and so cannot be bound")
|
||||
((memq x '(t nil))
|
||||
"cannot be bound")
|
||||
(t t)))
|
||||
|
||||
(defun legal-std-specializers-p (x)
|
||||
(flet ((improper-list nil (return-from legal-std-specializers-p "Is not a proper list.")))
|
||||
(dolist-carefully (s x improper-list)
|
||||
(let ((ok (legal-std-specializer-p s)))
|
||||
(unless (eq ok t)
|
||||
(return-from legal-std-specializers-p (format nil "Contains ~S which ~A"
|
||||
s ok)))))
|
||||
t))
|
||||
|
||||
(defun legal-std-specializer-p (x)
|
||||
(if (or (classp x)
|
||||
(eql-specializer-p x))
|
||||
t
|
||||
"is neither a class object nor an eql specializer"))
|
||||
@@ -1,757 +0,0 @@
|
||||
;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
|
||||
;;;
|
||||
;;; *************************************************************************
|
||||
;;; Copyright (c) 1991 Venue
|
||||
;;; All rights reserved.
|
||||
;;; *************************************************************************
|
||||
;;;
|
||||
;;; Some support stuff for compiling and loading CLOS. It would be nice if
|
||||
;;; there was some portable make-system we could all agree to share for a
|
||||
;;; while. At least until people really get databases and stuff.
|
||||
;;;
|
||||
;;; *** ***
|
||||
;;; *** DIRECTIONS FOR INSTALLING CLOS AT YOUR SITE ***
|
||||
;;; *** ***
|
||||
;;;
|
||||
;;; To get CLOS working at your site you should:
|
||||
;;;
|
||||
;;; - Get all the CLOS source files from Xerox. The complete list of source
|
||||
;;; file names can be found in the defsystem for CLOS which appears towards
|
||||
;;; the end of this file.
|
||||
;;;
|
||||
;;; - Edit the variable *clos-directory* below to specify the directory at
|
||||
;;; your site where the clos sources and binaries will be. This variable
|
||||
;;; can be found by searching from this point for the string "***" in
|
||||
;;; this file.
|
||||
;;;
|
||||
;;; - Use the function (clos::compile-clos) to compile CLOS for your site.
|
||||
;;;
|
||||
;;; - Once CLOS has been compiled it can be loaded with (clos::load-clos).
|
||||
;;; Note that CLOS cannot be loaded on top of itself, nor can it be
|
||||
;;; loaded into the same world it was compiled in.
|
||||
;;;
|
||||
|
||||
(in-package "CLOS" :use (list (or (find-package :walker)
|
||||
(make-package :walker :use '(:lisp)))
|
||||
(or (find-package :iterate)
|
||||
(make-package :iterate
|
||||
:use '(:lisp :walker)))
|
||||
(find-package :lisp)))
|
||||
|
||||
(export (intern (symbol-name :iterate) ;Have to do this here,
|
||||
(find-package :iterate)) ;because in the defsystem
|
||||
(find-package :iterate)) ;(later in this file)
|
||||
;we use the symbol iterate
|
||||
;to name the file
|
||||
|
||||
;;;
|
||||
;;; Sure, its weird for this to be here, but in order to follow the rules
|
||||
;;; about order of export and all that stuff, we can't put it in PKG before
|
||||
;;; we want to use it.
|
||||
;;;
|
||||
(defvar *the-clos-package* (find-package :clos))
|
||||
|
||||
(defvar *clos-system-date* "5/10/91 Interim CLOS release")
|
||||
|
||||
|
||||
;;;
|
||||
;;; Various hacks to get people's *features* into better shape.
|
||||
;;;
|
||||
(eval-when (compile load eval)
|
||||
#+(and Symbolics Lispm)
|
||||
(multiple-value-bind (major minor) (sct:get-release-version)
|
||||
(etypecase minor
|
||||
(integer)
|
||||
(string (setf minor (parse-integer minor :junk-allowed t))))
|
||||
(pushnew :genera *features*)
|
||||
(ecase major
|
||||
((6)
|
||||
(pushnew :genera-release-6 *features*))
|
||||
((7)
|
||||
(pushnew :genera-release-7 *features*)
|
||||
(ecase minor
|
||||
((0 1) (pushnew :genera-release-7-1 *features*))
|
||||
((2) (pushnew :genera-release-7-2 *features*))
|
||||
((3) (pushnew :genera-release-7-3 *features*))
|
||||
((4) (pushnew :genera-release-7-4 *features*))))
|
||||
((8)
|
||||
(pushnew :genera-release-8 *features*)
|
||||
(ecase minor
|
||||
((0) (pushnew :genera-release-8-0 *features*))
|
||||
((1) (pushnew :genera-release-8-1 *features*))))))
|
||||
|
||||
#+CLOE-Runtime
|
||||
(let ((version (lisp-implementation-version)))
|
||||
(when (string-equal version "2.0" :end1 (min 3 (length version)))
|
||||
(pushnew :cloe-release-2 *features*)))
|
||||
|
||||
(dolist (feature *features*)
|
||||
(when (and (symbolp feature) ;3600!!
|
||||
(equal (symbol-name feature) "CMU"))
|
||||
(pushnew :CMU *features*)))
|
||||
|
||||
#+TI
|
||||
(if (eq (si:local-binary-file-type) :xld)
|
||||
(pushnew ':ti-release-3 *features*)
|
||||
(pushnew ':ti-release-2 *features*))
|
||||
|
||||
#+Lucid
|
||||
(when (search "IBM RT PC" (machine-type))
|
||||
(pushnew :ibm-rt-pc *features*))
|
||||
|
||||
#+ExCL
|
||||
(cond ((search "sun3" (lisp-implementation-version))
|
||||
(push :sun3 *features*))
|
||||
((search "sun4" (lisp-implementation-version))
|
||||
(push :sun4 *features*)))
|
||||
|
||||
#+(and HP Lucid)
|
||||
(push :HP-Lucid *features*)
|
||||
#+(and HP (not Lucid))
|
||||
(push :HP-HPLabs *features*)
|
||||
|
||||
#+Xerox
|
||||
(case il:makesysname
|
||||
(:lyric (push :Xerox-Lyric *features*))
|
||||
(otherwise (pushnew :Xerox-Medley *features*)))
|
||||
;;;
|
||||
;;; For KCL and IBCL, push the symbol :turbo-closure on the list *features*
|
||||
;;; if you have installed turbo-closure patch. See the file kcl-mods.text
|
||||
;;; for details.
|
||||
;;;
|
||||
;;; The xkcl version of KCL has this fixed already.
|
||||
;;;
|
||||
|
||||
#+xkcl(pushnew :turbo-closure *features*)
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
||||
;;; Yet Another Sort Of General System Facility and friends.
|
||||
;;;
|
||||
;;; The entry points are defsystem and operate-on-system. defsystem is used
|
||||
;;; to define a new system and the files with their load/compile constraints.
|
||||
;;; Operate-on-system is used to operate on a system defined that has been
|
||||
;;; defined by defsystem. For example:
|
||||
#||
|
||||
|
||||
(defsystem my-very-own-system
|
||||
"/usr/myname/lisp/"
|
||||
((classes (precom) () ())
|
||||
(methods (precom classes) (classes) ())
|
||||
(precom () (classes methods) (classes methods))))
|
||||
|
||||
This defsystem should be read as follows:
|
||||
|
||||
* Define a system named MY-VERY-OWN-SYSTEM, the sources and binaries
|
||||
should be in the directory "/usr/me/lisp/". There are three files
|
||||
in the system, there are named classes, methods and precom. (The
|
||||
extension the filenames have depends on the lisp you are running in.)
|
||||
|
||||
* For the first file, classes, the (precom) in the line means that
|
||||
the file precom should be loaded before this file is loaded. The
|
||||
first () means that no other files need to be loaded before this
|
||||
file is compiled. The second () means that changes in other files
|
||||
don't force this file to be recompiled.
|
||||
|
||||
* For the second file, methods, the (precom classes) means that both
|
||||
of the files precom and classes must be loaded before this file
|
||||
can be loaded. The (classes) means that the file classes must be
|
||||
loaded before this file can be compiled. The () means that changes
|
||||
in other files don't force this file to be recompiled.
|
||||
|
||||
* For the third file, precom, the first () means that no other files
|
||||
need to be loaded before this file is loaded. The first use of
|
||||
(classes methods) means that both classes and methods must be
|
||||
loaded before this file can be compiled. The second use of (classes
|
||||
methods) mean that whenever either classes or methods changes precom
|
||||
must be recompiled.
|
||||
|
||||
Then you can compile your system with:
|
||||
|
||||
(operate-on-system 'my-very-own-system :compile)
|
||||
|
||||
and load your system with:
|
||||
|
||||
(operate-on-system 'my-very-own-system :load)
|
||||
|
||||
||#
|
||||
|
||||
;;;
|
||||
(defvar *system-directory*)
|
||||
|
||||
;;;
|
||||
;;; *port* is a list of symbols (in the CLOS package) which represent the
|
||||
;;; Common Lisp in which we are now running. Many of the facilities in
|
||||
;;; defsys use the value of *port* rather than #+ and #- to conditionalize
|
||||
;;; the way they work.
|
||||
;;;
|
||||
(defvar *port*
|
||||
'(#+Genera Genera
|
||||
; #+Genera-Release-6 Rel-6
|
||||
; #+Genera-Release-7-1 Rel-7
|
||||
#+Genera-Release-7-2 Rel-7
|
||||
#+Genera-Release-7-3 Rel-7
|
||||
#+Genera-Release-7-1 Rel-7-1
|
||||
#+Genera-Release-7-2 Rel-7-2
|
||||
#+Genera-Release-7-3 Rel-7-2 ;OK for now
|
||||
#+Genera-Release-7-4 Rel-7-2 ;OK for now
|
||||
#+Genera-Release-8 Rel-8
|
||||
#+imach Ivory
|
||||
#+Cloe-Runtime Cloe
|
||||
#+Lucid Lucid
|
||||
#+Xerox Xerox
|
||||
#+Xerox-Lyric Xerox-Lyric
|
||||
#+Xerox-Medley Xerox-Medley
|
||||
#+TI TI
|
||||
#+(and dec vax common) Vaxlisp
|
||||
#+KCL KCL
|
||||
#+IBCL IBCL
|
||||
#+excl excl
|
||||
#+(and excl sun4) excl-sun4
|
||||
#+:CMU CMU
|
||||
#+HP-HPLabs HP-HPLabs
|
||||
#+:gclisp gclisp
|
||||
#+pyramid pyramid
|
||||
#+:coral coral))
|
||||
|
||||
;;;
|
||||
;;; When you get a copy of CLOS (by tape or by FTP), the sources files will
|
||||
;;; have extensions of ".lisp" in particular, this file will be defsys.lisp.
|
||||
;;; The preferred way to install clos is to rename these files to have the
|
||||
;;; extension which your lisp likes to use for its files. Alternately, it
|
||||
;;; is possible not to rename the files. If the files are not renamed to
|
||||
;;; the proper convention, the second line of the following defvar should
|
||||
;;; be changed to:
|
||||
;;; (let ((files-renamed-p nil)
|
||||
;;;
|
||||
;;; Note: Something people installing CLOS on a machine running Unix
|
||||
;;; might find useful. If you want to change the extensions
|
||||
;;; of the source files from ".lisp" to ".lsp", *all* you have
|
||||
;;; to do is the following:
|
||||
;;;
|
||||
;;; % foreach i (*.lisp)
|
||||
;;; ? mv $i $i:r.lsp
|
||||
;;; ? end
|
||||
;;; %
|
||||
;;;
|
||||
;;; I am sure that a lot of people already know that, and some
|
||||
;;; Unix hackers may say, "jeez who doesn't know that". Those
|
||||
;;; same Unix hackers are invited to fix mv so that I can type
|
||||
;;; "mv *.lisp *.lsp".
|
||||
;;;
|
||||
(defvar *pathname-extensions*
|
||||
(let ((files-renamed-p t)
|
||||
(proper-extensions
|
||||
(car
|
||||
'(#+(and Genera (not imach)) ("lisp" . "bin")
|
||||
#+(and Genera imach) ("lisp" . "ibin")
|
||||
#+Cloe-Runtime ("l" . "fasl")
|
||||
#+(and dec common vax (not ultrix)) ("LSP" . "FAS")
|
||||
#+(and dec common vax ultrix) ("lsp" . "fas")
|
||||
#+KCL ("lsp" . "o")
|
||||
#+IBCL ("lsp" . "o")
|
||||
#+Xerox ("lisp" . "dfasl")
|
||||
#+(and Lucid MC68000) ("lisp" . "lbin")
|
||||
#+(and Lucid VAX) ("lisp" . "vbin")
|
||||
#+(and Lucid Prime) ("lisp" . "pbin")
|
||||
#+(and Lucid SUNRise) ("lisp" . "sbin")
|
||||
#+(and Lucid SPARC) ("lisp" . "sbin")
|
||||
#+(and Lucid IBM-RT-PC) ("lisp" . "bbin")
|
||||
#+(and Lucid MIPS) ("lisp" . "mbin")
|
||||
#+(and Lucid PRISM) ("lisp" . "abin")
|
||||
#+(and Lucid PA) ("lisp" . "hbin")
|
||||
#+excl ("cl" . "fasl")
|
||||
#+:CMU ("slisp" . "sfasl")
|
||||
#+HP ("l" . "b")
|
||||
#+TI ("lisp" . #.(string (si::local-binary-file-type)))
|
||||
#+:gclisp ("LSP" . "F2S")
|
||||
#+pyramid ("clisp" . "o")
|
||||
#+:coral ("lisp" . "fasl")
|
||||
))))
|
||||
(cond ((null proper-extensions) '("l" . "lbin"))
|
||||
((null files-renamed-p) (cons "lisp" (cdr proper-extensions)))
|
||||
(t proper-extensions))))
|
||||
|
||||
(eval-when (compile load eval)
|
||||
|
||||
(defun get-system (name)
|
||||
(get name 'system-definition))
|
||||
|
||||
(defun set-system (name new-value)
|
||||
(setf (get name 'system-definition) new-value))
|
||||
|
||||
(defmacro defsystem (name directory files)
|
||||
`(set-system ',name (list #'(lambda () ,directory)
|
||||
(make-modules ',files)
|
||||
',(mapcar #'car files))))
|
||||
|
||||
)
|
||||
|
||||
|
||||
;;;
|
||||
;;; The internal datastructure used when operating on a system.
|
||||
;;;
|
||||
(defstruct (module (:constructor make-module (name))
|
||||
(:print-function
|
||||
(lambda (m s d)
|
||||
(declare (ignore d))
|
||||
(format s "#<Module ~A>" (module-name m)))))
|
||||
name
|
||||
load-env
|
||||
comp-env
|
||||
recomp-reasons)
|
||||
|
||||
(defun make-modules (system-description)
|
||||
(let ((modules ()))
|
||||
(labels ((get-module (name)
|
||||
(or (find name modules :key #'module-name)
|
||||
(progn (setq modules (cons (make-module name) modules))
|
||||
(car modules))))
|
||||
(parse-spec (spec)
|
||||
(if (eq spec 't)
|
||||
(reverse (cdr modules))
|
||||
(case (car spec)
|
||||
(+ (append (reverse (cdr modules)) (mapcar #'get-module (cdr spec))))
|
||||
(- (let ((rem (mapcar #'get-module (cdr spec))))
|
||||
(remove-if #'(lambda (m) (member m rem)) (reverse (cdr modules)))))
|
||||
(otherwise (mapcar #'get-module spec))))))
|
||||
(dolist (file system-description)
|
||||
(let* ((name (car file))
|
||||
(port (car (cddddr file)))
|
||||
(module nil))
|
||||
(when (or (null port)
|
||||
(member port *port*))
|
||||
(setq module (get-module name))
|
||||
(setf (module-load-env module) (parse-spec (cadr file))
|
||||
(module-comp-env module) (parse-spec (caddr file))
|
||||
(module-recomp-reasons module) (parse-spec
|
||||
(cadddr file))))))
|
||||
(let ((filenames (mapcar #'car system-description)))
|
||||
(sort modules #'(lambda (name1 name2)
|
||||
(member name2 (member name1 filenames)))
|
||||
:key #'module-name)))))
|
||||
|
||||
|
||||
(defun make-transformations (modules filter make-transform)
|
||||
(let ((transforms (list nil)))
|
||||
(dolist (m modules)
|
||||
(when (funcall filter m transforms) (funcall make-transform m transforms)))
|
||||
(reverse (cdr transforms))))
|
||||
|
||||
(defun make-compile-transformation (module transforms)
|
||||
(unless (dolist (trans transforms)
|
||||
(and (eq (car trans) ':compile)
|
||||
(eq (cadr trans) module)
|
||||
(return t)))
|
||||
(dolist (c (module-comp-env module)) (make-load-transformation c transforms))
|
||||
(setf (cdr transforms)
|
||||
(remove-if #'(lambda (trans) (and (eq (car trans) :load) (eq (cadr trans) module)))
|
||||
(cdr transforms)))
|
||||
(push `(:compile ,module) (cdr transforms))))
|
||||
|
||||
(defvar *being-loaded* ())
|
||||
|
||||
(defun make-load-transformation (module transforms)
|
||||
(if (assoc module *being-loaded*)
|
||||
(throw module (setf (cdr transforms) (cdr (assoc module *being-loaded*))))
|
||||
(let ((*being-loaded* (cons (cons module (cdr transforms)) *being-loaded*)))
|
||||
(catch module
|
||||
(unless (dolist (trans transforms)
|
||||
(when (and (eq (car trans) ':load)
|
||||
(eq (cadr trans) module))
|
||||
(return t)))
|
||||
(dolist (l (module-load-env module)) (make-load-transformation l transforms))
|
||||
(push `(:load ,module) (cdr transforms)))))))
|
||||
|
||||
(defun make-load-without-dependencies-transformation (module transforms)
|
||||
(unless (dolist (trans transforms)
|
||||
(and (eq (car trans) ':load)
|
||||
(eq (cadr trans) module)
|
||||
(return trans)))
|
||||
(push `(:load ,module) (cdr transforms))))
|
||||
|
||||
(defun compile-filter (module transforms)
|
||||
(or (dolist (r (module-recomp-reasons module))
|
||||
(when (dolist (transform transforms)
|
||||
(when (and (eq (car transform) ':compile)
|
||||
(eq (cadr transform) r))
|
||||
(return t)))
|
||||
(return t)))
|
||||
(null (probe-file (make-binary-pathname (module-name module))))
|
||||
(> (file-write-date (make-source-pathname (module-name module)))
|
||||
(file-write-date (make-binary-pathname (module-name module))))))
|
||||
|
||||
(defun operate-on-system (name mode &optional arg print-only)
|
||||
(let ((system (get-system name)))
|
||||
(unless system (error "Can't find system with name ~S." name))
|
||||
(let ((*system-directory* (funcall (car system)))
|
||||
(modules (cadr system))
|
||||
(transformations ()))
|
||||
(labels ((load-source (name pathname)
|
||||
(format t "~&Loading source of ~A..." name)
|
||||
(or print-only (load pathname)))
|
||||
(load-binary (name pathname)
|
||||
(format t "~&Loading binary of ~A..." name)
|
||||
(or print-only (load pathname)))
|
||||
(load-module (m)
|
||||
(let* ((name (module-name m))
|
||||
(*load-verbose* nil)
|
||||
(binary (make-binary-pathname name)))
|
||||
(load-binary name binary)))
|
||||
(compile-module (m)
|
||||
(format t "~&Compiling ~A..." (module-name m))
|
||||
(unless print-only
|
||||
(let ((name (module-name m)))
|
||||
(compile-file (make-source-pathname name)
|
||||
:output-file
|
||||
(make-pathname :defaults
|
||||
(make-binary-pathname name)
|
||||
:version :newest)))))
|
||||
(xcl:true (&rest ignore) (declare (ignore ignore)) 't))
|
||||
|
||||
(setq transformations
|
||||
(ecase mode
|
||||
(:compile
|
||||
;; Compile any files that have changed and any other files
|
||||
;; that require recompilation when another file has been
|
||||
;; recompiled.
|
||||
(make-transformations
|
||||
modules
|
||||
#'compile-filter
|
||||
#'make-compile-transformation))
|
||||
(:recompile
|
||||
;; Force recompilation of all files.
|
||||
(make-transformations
|
||||
modules
|
||||
#'xcl:true
|
||||
#'make-compile-transformation))
|
||||
(:recompile-some
|
||||
;; Force recompilation of some files. Also compile the
|
||||
;; files that require recompilation when another file has
|
||||
;; been recompiled.
|
||||
(make-transformations
|
||||
modules
|
||||
#'(lambda (m transforms)
|
||||
(or (member (module-name m) arg)
|
||||
(compile-filter m transforms)))
|
||||
#'make-compile-transformation))
|
||||
(:query-compile
|
||||
;; Ask the user which files to compile. Compile those
|
||||
;; and any other files which must be recompiled when
|
||||
;; another file has been recompiled.
|
||||
(make-transformations
|
||||
modules
|
||||
#'(lambda (m transforms)
|
||||
(or (compile-filter m transforms)
|
||||
(y-or-n-p "Compile ~A?"
|
||||
(module-name m))))
|
||||
#'make-compile-transformation))
|
||||
(:confirm-compile
|
||||
;; Offer the user a chance to prevent a file from being
|
||||
;; recompiled.
|
||||
(make-transformations
|
||||
modules
|
||||
#'(lambda (m transforms)
|
||||
(and (compile-filter m transforms)
|
||||
(y-or-n-p "Go ahead and compile ~A?"
|
||||
(module-name m))))
|
||||
#'make-compile-transformation))
|
||||
(:load
|
||||
;; Load the whole system.
|
||||
(make-transformations
|
||||
modules
|
||||
#'xcl:true
|
||||
#'make-load-transformation))
|
||||
(:query-load
|
||||
;; Load only those files the user says to load.
|
||||
(make-transformations
|
||||
modules
|
||||
#'(lambda (m transforms)
|
||||
(declare (ignore transforms))
|
||||
(y-or-n-p "Load ~A?" (module-name m)))
|
||||
#'make-load-without-dependencies-transformation))))
|
||||
|
||||
(#+Genera
|
||||
compiler:compiler-warnings-context-bind
|
||||
#+TI
|
||||
COMPILER:COMPILER-WARNINGS-CONTEXT-BIND
|
||||
#+:LCL3.0
|
||||
lucid-common-lisp:with-deferred-warnings
|
||||
#-(or Genera TI :LCL3.0)
|
||||
progn
|
||||
(loop (when (null transformations) (return t))
|
||||
(let ((transform (pop transformations)))
|
||||
(ecase (car transform)
|
||||
(:compile (compile-module (cadr transform)))
|
||||
(:load (load-module (cadr transform)))))))))))
|
||||
|
||||
|
||||
(defun make-source-pathname (name) (make-pathname-internal name :source))
|
||||
(defun make-binary-pathname (name) (make-pathname-internal name :binary))
|
||||
|
||||
(defun make-pathname-internal (name type)
|
||||
(let* ((extension (ecase type
|
||||
(:source (car *pathname-extensions*))
|
||||
(:binary (cdr *pathname-extensions*))))
|
||||
(directory (pathname
|
||||
(etypecase *system-directory*
|
||||
(string *system-directory*)
|
||||
(pathname *system-directory*)
|
||||
(cons (ecase type
|
||||
(:source (car *system-directory*))
|
||||
(:binary (cdr *system-directory*)))))))
|
||||
(pathname
|
||||
(make-pathname
|
||||
:name (string-downcase (string name))
|
||||
:type extension
|
||||
:defaults directory :version :newest)))
|
||||
|
||||
#+Genera
|
||||
(setq pathname (zl:send pathname :new-raw-name (pathname-name pathname))
|
||||
pathname (zl:send pathname :new-raw-type (pathname-type pathname)))
|
||||
|
||||
pathname))
|
||||
|
||||
|
||||
|
||||
;;; *** SITE SPECIFIC CLOS DIRECTORY ***
|
||||
;;;
|
||||
;;; *clos-directory* is a variable which specifies the directory clos is stored
|
||||
;;; in at your site. If the value of the variable is a single pathname, the
|
||||
;;; sources and binaries should be stored in that directory. If the value of
|
||||
;;; that directory is a cons, the CAR should be the source directory and the
|
||||
;;; CDR should be the binary directory.
|
||||
;;;
|
||||
;;; By default, the value of *clos-directory* is set to the directory that
|
||||
;;; this file is loaded from. This makes it simple to keep multiple copies
|
||||
;;; of CLOS in different places, just load defsys from the same directory as
|
||||
;;; the copy of CLOS you want to use.
|
||||
;;;
|
||||
;;; Note that the value of *CLOS-DIRECTORY* is set using a DEFVAR. This is
|
||||
;;; done to make it possible for users to set it in their init file and then
|
||||
;;; load this file. The value set in the init file will override the value
|
||||
;;; here.
|
||||
;;;
|
||||
;;; *** ***
|
||||
|
||||
(defun load-truename (&optional (errorp nil))
|
||||
(flet ((bad-time ()
|
||||
(when errorp
|
||||
(error "LOAD-TRUENAME called but a file isn't being loaded."))))
|
||||
#+Lispm (or sys:fdefine-file-pathname (bad-time))
|
||||
#+excl excl::*source-pathname*
|
||||
#+Xerox (pathname (or (il:fullname *standard-input*) (bad-time)))
|
||||
#+(and dec vax common) (truename (sys::source-file #'load-truename))
|
||||
;;
|
||||
;; The following use of `lucid::' is a kludge for 2.1 and 3.0
|
||||
;; compatibility. In 2.1 it was in the SYSTEM package, and i
|
||||
;; 3.0 it's in the LUCID-COMMON-LISP package.
|
||||
;;
|
||||
#+LUCID (or lucid::*source-pathname* (bad-time))
|
||||
#-(or Lispm excl Xerox (and dec vax common) LUCID) nil))
|
||||
|
||||
#-Symbolics
|
||||
(defvar *clos-directory*
|
||||
(or (load-truename t)
|
||||
(error "Because load-truename is not implemented in this port~%~
|
||||
of CLOS, you must manually edit the definition of the~%~
|
||||
variable *clos-directory* in the file defsys.lisp.")))
|
||||
|
||||
#+Genera
|
||||
(defvar *clos-directory*
|
||||
(let ((source (load-truename t)))
|
||||
(flet ((subdir (name)
|
||||
(scl:send source :new-pathname :raw-directory
|
||||
(append (scl:send source :raw-directory)
|
||||
(list name)))))
|
||||
(cons source
|
||||
#+genera-release-7-2 (subdir "rel-7-2")
|
||||
#+genera-release-7-3 (subdir "rel-7-3")
|
||||
#+genera-release-7-4 (subdir "rel-7-4")
|
||||
#+genera-release-8-0 (subdir "rel-8-0")
|
||||
#+genera-release-8-1 (subdir "rel-8-1")
|
||||
))))
|
||||
|
||||
#+Cloe-Runtime
|
||||
(defvar *clos-directory* (pathname "/usr3/hornig/clos/"))
|
||||
|
||||
(defsystem clos
|
||||
*clos-directory*
|
||||
;;
|
||||
;; file load compile files which port
|
||||
;; environment environment force the of
|
||||
;; recompilation
|
||||
;; of this file
|
||||
;;
|
||||
(
|
||||
(patch t t () xerox)
|
||||
(pkg t t ())
|
||||
(walk (pkg) (pkg) ())
|
||||
(iterate t t ())
|
||||
(macros t t ())
|
||||
(low (pkg macros) t (macros))
|
||||
(low2 (low) (low) (low) Xerox)
|
||||
(fin t t (low))
|
||||
(defclass t t (low))
|
||||
(defs t t (defclass macros iterate))
|
||||
(fngen t t (low))
|
||||
(lap t t (low))
|
||||
(plap t t (low))
|
||||
(cache t t (low defs))
|
||||
(dlap t t (defs low fin cache lap))
|
||||
(boot t t (defs fin))
|
||||
(vector t t (boot defs cache fin))
|
||||
(slots t t (vector boot defs low cache fin))
|
||||
(init t t (vector boot defs low cache fin))
|
||||
(std-class t t (vector boot defs low cache fin slots))
|
||||
(cpl t t (vector boot defs low cache fin slots))
|
||||
(braid t t (boot defs low fin cache))
|
||||
(fsc t t (defclass boot defs low fin cache))
|
||||
(methods t t (defclass boot defs low fin cache))
|
||||
(combin t t (defclass boot defs low fin cache))
|
||||
(dfun t t (dlap))
|
||||
(fixup (+ precom1 precom2 precom4) t (boot defs low fin))
|
||||
(defcombin t t (defclass boot defs low fin))
|
||||
(ctypes t t (defclass defcombin))
|
||||
(construct t t (defclass boot defs low))
|
||||
(env t t (defclass boot defs low fin))
|
||||
(compat t t ())
|
||||
(precom1 (dlap) t (defs low cache fin dfun))
|
||||
(precom2 (dlap) t (defs low cache fin dfun))
|
||||
(precom4 (dlap) t (defs low cache fin dfun))
|
||||
))
|
||||
|
||||
(defun compile-clos (&optional m)
|
||||
(let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
|
||||
#+Lucid (lcl:*redefinition-action* nil)
|
||||
#+excl (excl::*redefinition-warnings* nil)
|
||||
#+Genera (sys:inhibit-fdefine-warnings t)
|
||||
)
|
||||
(cond ((null m) (operate-on-system 'clos :compile))
|
||||
((eq m :print) (operate-on-system 'clos :compile () t))
|
||||
((eq m :query) (operate-on-system 'clos :query-compile))
|
||||
((eq m :confirm) (operate-on-system 'clos :confirm-compile))
|
||||
((eq m 't) (operate-on-system 'clos :recompile))
|
||||
((listp m) (operate-on-system 'clos :compile-from m))
|
||||
((symbolp m) (operate-on-system 'clos :recompile-some `(,m))))))
|
||||
|
||||
(defun load-clos (&optional m)
|
||||
(let (#+:coral(ccl::*warn-if-redefine-kernel* nil)
|
||||
#+Lucid (lcl:*redefinition-action* nil)
|
||||
#+excl (excl::*redefinition-warnings* nil)
|
||||
#+Genera (sys:inhibit-fdefine-warnings t)
|
||||
)
|
||||
(cond ((null m) (operate-on-system 'clos :load))
|
||||
((eq m :query) (operate-on-system 'clos :query-load)))
|
||||
(pushnew :clos *features*)))
|
||||
|
||||
#+Genera
|
||||
;;; Make sure Genera bug mail contains the CLOS bug data. A little
|
||||
;;; kludgy, but what the heck. If they didn't mean for people to do
|
||||
;;; this, they wouldn't have made private patch notes be flavored
|
||||
;;; objects, right? Right.
|
||||
(progn
|
||||
(scl:defflavor clos-private-patch-info ((description)) ())
|
||||
(scl:defmethod (sct::private-patch-info-description clos-private-patch-info) ()
|
||||
(or description
|
||||
(setf description (string-append "CLOS version: " *clos-system-date*))))
|
||||
(scl:defmethod (sct::private-patch-info-pathname clos-private-patch-info) ()
|
||||
*clos-directory*)
|
||||
(unless (find-if #'(lambda (x) (typep x 'clos-private-patch-info))
|
||||
sct::*private-patch-info*)
|
||||
(push (scl:make-instance 'clos-private-patch-info)
|
||||
sct::*private-patch-info*)))
|
||||
|
||||
(defun bug-report-info (&optional (stream *standard-output*))
|
||||
(format stream "~&CLOS system date: ~A~
|
||||
~&Lisp Implementation type: ~A~
|
||||
~&Lisp Implementation version: ~A~
|
||||
~&*features*: ~S"
|
||||
*clos-system-date*
|
||||
(lisp-implementation-type)
|
||||
(lisp-implementation-version)
|
||||
*features*))
|
||||
|
||||
|
||||
|
||||
;;;;
|
||||
;;;
|
||||
;;; This stuff is not intended for external use.
|
||||
;;;
|
||||
(defun rename-clos ()
|
||||
(dolist (f (cadr (get-system 'clos)))
|
||||
(let ((old nil)
|
||||
(new nil))
|
||||
(let ((*system-directory* *default-pathname-defaults*))
|
||||
(setq old (make-source-pathname (car f))))
|
||||
(setq new (make-source-pathname (car f)))
|
||||
(rename-file old new))))
|
||||
|
||||
#+Genera
|
||||
(defun edit-clos ()
|
||||
(dolist (f (cadr (get-system 'clos)))
|
||||
(let ((*system-directory* *clos-directory*))
|
||||
(zwei:find-file (make-source-pathname (car f))))))
|
||||
|
||||
#+Genera
|
||||
(defun hardcopy-clos (&optional query-p)
|
||||
(let ((files (mapcar #'(lambda (f)
|
||||
(setq f (car f))
|
||||
(and (or (not query-p)
|
||||
(y-or-n-p "~A? " f))
|
||||
f))
|
||||
(cadr (get-system 'clos))))
|
||||
(b zwei:*interval*))
|
||||
(unwind-protect
|
||||
(dolist (f files)
|
||||
(when f
|
||||
(multiple-value-bind (ignore b)
|
||||
(zwei:find-file (make-source-pathname f))
|
||||
(zwei:hardcopy-buffer b))))
|
||||
(zwei:make-buffer-current b))))
|
||||
|
||||
|
||||
;;;
|
||||
;;; unido!ztivax!dae@seismo.css.gov
|
||||
;;; z30083%tansei.cc.u-tokyo.junet@utokyo-relay.csnet
|
||||
;;; Victor@carmen.uu.se
|
||||
;;; mcvax!harlqn.co.uk!chris@uunet.UU.NET
|
||||
;;;
|
||||
#+Genera
|
||||
(defun mail-clos (to)
|
||||
(let* ((original-buffer zwei:*interval*)
|
||||
(*system-directory* (pathname "vaxc:/user/ftp/pub/clos/")
|
||||
;(funcall (car (get-system 'clos)))
|
||||
)
|
||||
(files (list* 'defsys
|
||||
'test
|
||||
(caddr (get-system 'clos))))
|
||||
(total-number (length files))
|
||||
(file nil)
|
||||
(number-of-lines 0)
|
||||
(i 0)
|
||||
(mail-buffer nil))
|
||||
(unwind-protect
|
||||
(loop
|
||||
(when (null files) (return nil))
|
||||
(setq file (pop files))
|
||||
(incf i)
|
||||
(multiple-value-bind (ignore b)
|
||||
(zwei:find-file (make-source-pathname file))
|
||||
(setq number-of-lines (zwei:count-lines b))
|
||||
(zwei:com-mail-internal t
|
||||
:initial-to to
|
||||
:initial-body b
|
||||
:initial-subject
|
||||
(format nil
|
||||
"CLOS file ~A (~A of ~A) ~D lines"
|
||||
file i total-number number-of-lines))
|
||||
(setq mail-buffer zwei:*interval*)
|
||||
(zwei:com-exit-com-mail)
|
||||
(format t "~&Just sent ~A (~A of ~A)." b i total-number)
|
||||
(zwei:kill-buffer mail-buffer)))
|
||||
(zwei:make-buffer-current original-buffer))))
|
||||
|
||||
|
||||
@@ -1,606 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
|
||||
; ************************************************************************
|
||||
; temporary for data gathering
|
||||
; temporary for data gathering
|
||||
; ************************************************************************
|
||||
|
||||
|
||||
(defvar *dfun-states* (make-hash-table :test #'eq))
|
||||
|
||||
(defun notice-dfun-state (generic-function state &optional nkeys valuep)
|
||||
(setf (gethash generic-function *dfun-states*)
|
||||
(cons state (when nkeys (list nkeys valuep)))))
|
||||
|
||||
|
||||
; ************************************************************************
|
||||
; temporary for data gathering
|
||||
; temporary for data gathering
|
||||
; ************************************************************************
|
||||
|
||||
|
||||
(defvar *dfun-constructors* nil)
|
||||
|
||||
; An alist in which each entry is of
|
||||
; the form (<generator> . (<subentry>
|
||||
; ...)) Each subentry is of the form:
|
||||
; (<args> <constructor> <system>)
|
||||
|
||||
|
||||
(defvar *enable-dfun-constructor-caching* t)
|
||||
|
||||
; If this is NIL, then the whole
|
||||
; mechanism for caching dfun
|
||||
; constructors is turned off. The only
|
||||
; time that makes sense is when
|
||||
; debugging LAP code.
|
||||
|
||||
|
||||
(defun show-dfun-constructors nil (format t "~&DFUN constructor caching is ~A." (if
|
||||
*enable-dfun-constructor-caching*
|
||||
"enabled"
|
||||
"disabled"))
|
||||
(dolist (generator-entry *dfun-constructors*)
|
||||
(dolist (args-entry (cdr generator-entry))
|
||||
(format t "~&~S ~S" (cons (car generator-entry)
|
||||
(caar args-entry))
|
||||
(caddr args-entry)))))
|
||||
|
||||
(defun get-dfun-constructor (generator &rest args)
|
||||
(let* ((generator-entry (assq generator *dfun-constructors*))
|
||||
(args-entry (assoc args (cdr generator-entry)
|
||||
:test
|
||||
#'equal)))
|
||||
(if (null *enable-dfun-constructor-caching*)
|
||||
(apply (symbol-function generator)
|
||||
args)
|
||||
(or (cadr args-entry)
|
||||
(let ((new (apply (symbol-function generator)
|
||||
args)))
|
||||
(if generator-entry
|
||||
(push (list (copy-list args)
|
||||
new nil)
|
||||
(cdr generator-entry))
|
||||
(push (list generator (list (copy-list args)
|
||||
new nil))
|
||||
*dfun-constructors*))
|
||||
new)))))
|
||||
|
||||
(defun load-precompiled-dfun-constructor (generator args system constructor)
|
||||
(let* ((generator-entry (assq generator *dfun-constructors*))
|
||||
(args-entry (assoc args (cdr generator-entry)
|
||||
:test
|
||||
#'equal)))
|
||||
(unless args-entry
|
||||
(if generator-entry
|
||||
(push (list args constructor system)
|
||||
(cdr generator-entry))
|
||||
(push (list generator (list args constructor system))
|
||||
*dfun-constructors*)))))
|
||||
|
||||
(defmacro
|
||||
precompile-dfun-constructors
|
||||
(&optional system)
|
||||
(let
|
||||
((*precompiling-lap* t))
|
||||
`(progn
|
||||
,@(gathering1 (collecting)
|
||||
(dolist (generator-entry *dfun-constructors*)
|
||||
(dolist (args-entry (cdr generator-entry))
|
||||
(when (or (null (caddr args-entry))
|
||||
(eq (caddr args-entry)
|
||||
system))
|
||||
(multiple-value-bind (closure-variables arguments iregs vregs tregs lap)
|
||||
(apply (symbol-function (car generator-entry))
|
||||
(car args-entry))
|
||||
(gather1 (make-top-level-form `(precompile-dfun-constructor
|
||||
,(car generator-entry))
|
||||
'(load)
|
||||
`(load-precompiled-dfun-constructor
|
||||
',(car generator-entry)
|
||||
',(car args-entry)
|
||||
',system
|
||||
(precompile-lap-closure-generator ,closure-variables
|
||||
,arguments
|
||||
,iregs
|
||||
,vregs
|
||||
,tregs
|
||||
,lap))))))))))))
|
||||
|
||||
(defun make-initial-dfun (generic-function)
|
||||
#'(lambda (&rest args)
|
||||
(initial-dfun args generic-function)))
|
||||
|
||||
|
||||
;;; When all the methods of a generic function are automatically generated reader or writer methods
|
||||
;;; a number of special optimizations are possible. These are important because of the large number
|
||||
;;; of generic functions of this type. There are a number of cases: ONE-CLASS-ACCESSOR In this case,
|
||||
;;; the accessor generic function has only been called with one class of argument. There is no
|
||||
;;; cache vector, the wrapper of the one class, and the slot index are stored directly as closure
|
||||
;;; variables of the discriminating function. This case can convert to either of the next kind.
|
||||
;;; TWO-CLASS-ACCESSOR Like above, but two classes. This is common enough to do specially. There is
|
||||
;;; no cache vector. The two classes are stored a separate closure variables. ONE-INDEX-ACCESSOR In
|
||||
;;; this case, the accessor generic function has seen more than one class of argument, but the index
|
||||
;;; of the slot is the same for all the classes that have been seen. A cache vector is used to
|
||||
;;; store the wrappers that have been seen, the slot index is stored directly as a closure variable
|
||||
;;; of the discriminating function. This case can convert to the next kind. N-N-ACCESSOR This is
|
||||
;;; the most general case. In this case, the accessor generic function has seen more than one class
|
||||
;;; of argument and more than one slot index. A cache vector stores the wrappers and corresponding
|
||||
;;; slot indexes. Because each cache line is more than one element long, a cache lock count is
|
||||
;;; used. ONE-CLASS-ACCESSOR
|
||||
|
||||
|
||||
(defun update-to-one-class-readers-dfun (generic-function wrapper index)
|
||||
(let ((constructor (get-dfun-constructor 'emit-one-class-reader (consp index))))
|
||||
(notice-dfun-state generic-function `(one-class readers ,(consp index)))
|
||||
; ***
|
||||
(update-dfun generic-function (funcall constructor wrapper index
|
||||
#'(lambda (arg)
|
||||
(declare (clos-fast-call))
|
||||
(one-class-readers-miss arg
|
||||
generic-function index wrapper))))))
|
||||
|
||||
(defun update-to-one-class-writers-dfun (generic-function wrapper index)
|
||||
(let ((constructor (get-dfun-constructor 'emit-one-class-writer (consp index))))
|
||||
(notice-dfun-state generic-function `(one-class writers ,(consp index)))
|
||||
; ***
|
||||
(update-dfun generic-function (funcall constructor wrapper index
|
||||
#'(lambda (new-value arg)
|
||||
(declare (clos-fast-call))
|
||||
(one-class-writers-miss new-value arg
|
||||
generic-function index wrapper))))))
|
||||
|
||||
(defun one-class-readers-miss (arg generic-function index wrapper)
|
||||
(accessor-miss generic-function 'one-class 'reader nil arg index wrapper nil nil nil))
|
||||
|
||||
(defun one-class-writers-miss (new arg generic-function index wrapper)
|
||||
(accessor-miss generic-function 'one-class 'writer new arg index wrapper nil nil nil))
|
||||
|
||||
|
||||
;;; TWO-CLASS-ACCESSOR
|
||||
|
||||
|
||||
(defun update-to-two-class-readers-dfun (generic-function wrapper-0 wrapper-1 index)
|
||||
(let ((constructor (get-dfun-constructor 'emit-two-class-reader (consp index))))
|
||||
(notice-dfun-state generic-function `(two-class readers ,(consp index)))
|
||||
; ***
|
||||
(update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index
|
||||
#'(lambda (arg)
|
||||
(declare (clos-fast-call))
|
||||
(two-class-readers-miss arg
|
||||
generic-function index wrapper-0
|
||||
wrapper-1))))))
|
||||
|
||||
(defun update-to-two-class-writers-dfun (generic-function wrapper-0 wrapper-1 index)
|
||||
(let ((constructor (get-dfun-constructor 'emit-two-class-writer (consp index))))
|
||||
(notice-dfun-state generic-function `(two-class writers ,(consp index)))
|
||||
; ***
|
||||
(update-dfun generic-function (funcall constructor wrapper-0 wrapper-1 index
|
||||
#'(lambda (new-value arg)
|
||||
(declare (clos-fast-call))
|
||||
(two-class-writers-miss new-value arg
|
||||
generic-function index wrapper-0
|
||||
wrapper-1))))))
|
||||
|
||||
(defun two-class-readers-miss (arg generic-function index w0 w1)
|
||||
(accessor-miss generic-function 'two-class 'reader nil arg index w0 w1 nil nil))
|
||||
|
||||
(defun two-class-writers-miss (new arg generic-function index w0 w1)
|
||||
(accessor-miss generic-function 'two-class 'writer new arg index w0 w1 nil nil))
|
||||
|
||||
|
||||
;;; std accessors same index dfun
|
||||
|
||||
|
||||
(defun update-to-one-index-readers-dfun (generic-function index &optional field cache)
|
||||
(unless field
|
||||
(setq field (wrapper-field 'number)))
|
||||
(let ((constructor (get-dfun-constructor 'emit-one-index-readers (consp index))))
|
||||
(multiple-value-bind (mask size)
|
||||
(compute-cache-parameters 1 nil (or cache 4))
|
||||
(unless cache
|
||||
(setq cache (get-cache size)))
|
||||
(notice-dfun-state generic-function `(one-index readers ,(consp index)))
|
||||
; ***
|
||||
(update-dfun generic-function (funcall constructor field cache mask size index
|
||||
#'(lambda (arg)
|
||||
(declare (clos-fast-call))
|
||||
(one-index-readers-miss arg
|
||||
generic-function index field cache
|
||||
)))
|
||||
cache))))
|
||||
|
||||
(defun update-to-one-index-writers-dfun (generic-function index &optional field cache)
|
||||
(unless field
|
||||
(setq field (wrapper-field 'number)))
|
||||
(let ((constructor (get-dfun-constructor 'emit-one-index-writers (consp index))))
|
||||
(multiple-value-bind (mask size)
|
||||
(compute-cache-parameters 1 nil (or cache 4))
|
||||
(unless cache
|
||||
(setq cache (get-cache size)))
|
||||
(notice-dfun-state generic-function `(one-index writers ,(consp index)))
|
||||
; ***
|
||||
(update-dfun generic-function (funcall constructor field cache mask size index
|
||||
#'(lambda (new-value arg)
|
||||
(declare (clos-fast-call))
|
||||
(one-index-writers-miss new-value arg
|
||||
generic-function index field cache
|
||||
)))
|
||||
cache))))
|
||||
|
||||
(defun one-index-readers-miss (arg gf index field cache)
|
||||
(accessor-miss gf 'one-index 'reader nil arg index nil nil field cache))
|
||||
|
||||
(defun one-index-writers-miss (new arg gf index field cache)
|
||||
(accessor-miss gf 'one-index 'writer new arg index nil nil field cache))
|
||||
|
||||
(defun one-index-limit-fn (nlines)
|
||||
(default-limit-fn nlines))
|
||||
|
||||
(defun update-to-n-n-readers-dfun (generic-function &optional field cache)
|
||||
(unless field
|
||||
(setq field (wrapper-field 'number)))
|
||||
(let ((constructor (get-dfun-constructor 'emit-n-n-readers)))
|
||||
(multiple-value-bind (mask size)
|
||||
(compute-cache-parameters 1 t (or cache 2))
|
||||
(unless cache
|
||||
(setq cache (get-cache size)))
|
||||
(notice-dfun-state generic-function `(n-n readers))
|
||||
; ***
|
||||
(update-dfun generic-function (funcall constructor field cache mask size
|
||||
#'(lambda (arg)
|
||||
(declare (clos-fast-call))
|
||||
(n-n-readers-miss arg generic-function
|
||||
field cache)))
|
||||
cache))))
|
||||
|
||||
(defun update-to-n-n-writers-dfun (generic-function &optional field cache)
|
||||
(unless field
|
||||
(setq field (wrapper-field 'number)))
|
||||
(let ((constructor (get-dfun-constructor 'emit-n-n-writers)))
|
||||
(multiple-value-bind (mask size)
|
||||
(compute-cache-parameters 1 t (or cache 2))
|
||||
(unless cache
|
||||
(setq cache (get-cache size)))
|
||||
(notice-dfun-state generic-function `(n-n writers))
|
||||
; ***
|
||||
(update-dfun generic-function (funcall constructor field cache mask size
|
||||
#'(lambda (new arg)
|
||||
(declare (clos-fast-call))
|
||||
(n-n-writers-miss new arg
|
||||
generic-function field cache)))
|
||||
cache))))
|
||||
|
||||
(defun n-n-readers-miss (arg gf field cache)
|
||||
(accessor-miss gf 'n-n 'reader nil arg nil nil nil field cache))
|
||||
|
||||
(defun n-n-writers-miss (new arg gf field cache)
|
||||
(accessor-miss gf 'n-n 'writer new arg nil nil nil field cache))
|
||||
|
||||
(defun n-n-accessors-limit-fn (nlines)
|
||||
(default-limit-fn nlines))
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
(defun update-to-checking-dfun (generic-function function &optional field cache)
|
||||
(unless field
|
||||
(setq field (wrapper-field 'number)))
|
||||
(let* ((arg-info (gf-arg-info generic-function))
|
||||
(metatypes (arg-info-metatypes arg-info))
|
||||
(applyp (arg-info-applyp arg-info))
|
||||
(nkeys (arg-info-nkeys arg-info)))
|
||||
(if (every #'(lambda (mt)
|
||||
(eq mt 't))
|
||||
metatypes)
|
||||
(progn (notice-dfun-state generic-function `(default-method-only))
|
||||
; ***
|
||||
(update-dfun generic-function function))
|
||||
(multiple-value-bind (mask size)
|
||||
(compute-cache-parameters nkeys nil (or cache 2))
|
||||
(unless cache
|
||||
(setq cache (get-cache size)))
|
||||
(let ((constructor (get-dfun-constructor 'emit-checking metatypes applyp)))
|
||||
(notice-dfun-state generic-function '(checking)
|
||||
nkeys nil)
|
||||
; ****
|
||||
(update-dfun generic-function
|
||||
(funcall constructor field cache mask size function
|
||||
#'(lambda (&rest args)
|
||||
(declare (clos-fast-call))
|
||||
(checking-miss generic-function args function field
|
||||
cache)))
|
||||
cache))))))
|
||||
|
||||
(defun checking-limit-fn (nlines)
|
||||
(default-limit-fn nlines))
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
(defun update-to-caching-dfun (generic-function &optional field cache)
|
||||
(unless field
|
||||
(setq field (wrapper-field 'number)))
|
||||
(let* ((arg-info (gf-arg-info generic-function))
|
||||
(metatypes (arg-info-metatypes arg-info))
|
||||
(applyp (arg-info-applyp arg-info))
|
||||
(nkeys (arg-info-nkeys arg-info))
|
||||
(constructor (get-dfun-constructor 'emit-caching metatypes applyp)))
|
||||
(multiple-value-bind (mask size)
|
||||
(compute-cache-parameters nkeys t (or cache 2))
|
||||
(unless cache
|
||||
(setq cache (get-cache size)))
|
||||
(notice-dfun-state generic-function '(caching)
|
||||
nkeys t)
|
||||
; ****
|
||||
(update-dfun generic-function (funcall constructor field cache mask size
|
||||
#'(lambda (&rest args)
|
||||
(declare (clos-fast-call))
|
||||
(caching-miss generic-function args
|
||||
field cache)))
|
||||
cache))))
|
||||
|
||||
(defun caching-limit-fn (nlines)
|
||||
(default-limit-fn nlines))
|
||||
|
||||
|
||||
;;; The dynamically adaptive method lookup algorithm is implemented is implemented as a kind of
|
||||
;;; state machine. The kinds of discriminating function is the state, the various kinds of reasons
|
||||
;;; for a cache miss are the state transitions. The code which implements the transitions is all in
|
||||
;;; the miss handlers for each kind of dfun. Those appear here. Note that within the states that
|
||||
;;; cache, there are dfun updates which simply select a new cache or cache field. Those are not
|
||||
;;; considered as state transitions.
|
||||
|
||||
|
||||
(defun initial-dfun (args generic-function)
|
||||
(protect-cache-miss-code generic-function args
|
||||
(multiple-value-bind (wrappers invalidp nfunction applicable)
|
||||
(cache-miss-values generic-function args)
|
||||
(multiple-value-bind (ntype nindex)
|
||||
(accessor-miss-values generic-function applicable args)
|
||||
(cond ((null applicable)
|
||||
(apply #'no-applicable-method generic-function args))
|
||||
(invalidp (apply nfunction args))
|
||||
((and ntype nindex)
|
||||
(ecase ntype
|
||||
(reader (update-to-one-class-readers-dfun generic-function wrappers
|
||||
nindex))
|
||||
(writer (update-to-one-class-writers-dfun generic-function wrappers
|
||||
nindex)))
|
||||
(apply nfunction args))
|
||||
(ntype (apply nfunction args))
|
||||
(t (update-to-checking-dfun generic-function nfunction)
|
||||
(apply nfunction args)))))))
|
||||
|
||||
(defun
|
||||
accessor-miss
|
||||
(gf ostate otype new object oindex ow0 ow1 field cache)
|
||||
(declare (ignore ow1))
|
||||
(let ((args (ecase otype ; The congruence rules assure
|
||||
(reader (list object)) ; us that this is safe despite
|
||||
(writer (list new object)))))
|
||||
; not knowing the new type yet.
|
||||
(protect-cache-miss-code
|
||||
gf args
|
||||
(multiple-value-bind (wrappers invalidp nfunction applicable)
|
||||
(cache-miss-values gf args)
|
||||
(multiple-value-bind (ntype nindex)
|
||||
(accessor-miss-values gf applicable args)
|
||||
|
||||
;; The following lexical functions change the state of the dfun to that which is their
|
||||
;; name. They accept arguments which are the parameters of the new state, and get other
|
||||
;; information from the lexical variables bound above.
|
||||
(flet ((two-class (index w0 w1)
|
||||
(when (zerop (random 2))
|
||||
(psetf w0 w1 w1 w0))
|
||||
(ecase ntype
|
||||
(reader (update-to-two-class-readers-dfun gf w0 w1 index))
|
||||
(writer (update-to-two-class-writers-dfun gf w0 w1 index))))
|
||||
(one-index (index &optional field cache)
|
||||
(ecase ntype
|
||||
(reader (update-to-one-index-readers-dfun gf index field cache))
|
||||
(writer (update-to-one-index-writers-dfun gf index field cache))))
|
||||
(n-n (&optional field cache)
|
||||
(ecase ntype
|
||||
(reader (update-to-n-n-readers-dfun gf field cache))
|
||||
(writer (update-to-n-n-writers-dfun gf field cache))))
|
||||
(checking nil (update-to-checking-dfun gf nfunction))
|
||||
|
||||
;;
|
||||
(do-fill (valuep limit-fn update-fn)
|
||||
(multiple-value-bind (nfield ncache)
|
||||
(fill-cache field cache 1 valuep limit-fn wrappers nindex)
|
||||
(unless (and (= nfield field)
|
||||
(eq ncache cache))
|
||||
(funcall update-fn nfield ncache)))))
|
||||
(cond ((null nfunction)
|
||||
(apply #'no-applicable-method gf args))
|
||||
((null ntype)
|
||||
(checking)
|
||||
(apply nfunction args))
|
||||
((or invalidp (null nindex))
|
||||
(apply nfunction args))
|
||||
((not (or (std-instance-p object)
|
||||
(fsc-instance-p object)))
|
||||
(checking)
|
||||
(apply nfunction args))
|
||||
((neq ntype otype)
|
||||
(checking)
|
||||
(apply nfunction args))
|
||||
(t (ecase ostate
|
||||
(one-class (if (eql nindex oindex)
|
||||
(two-class nindex ow0 wrappers)
|
||||
(n-n)))
|
||||
(two-class (if (eql nindex oindex)
|
||||
(one-index nindex)
|
||||
(n-n)))
|
||||
(one-index (if (eql nindex oindex)
|
||||
(do-fill nil #'one-index-limit-fn
|
||||
#'(lambda (nfield ncache)
|
||||
(one-index nindex nfield ncache)))
|
||||
(n-n)))
|
||||
(n-n (unless (consp nindex)
|
||||
(do-fill t #'n-n-accessors-limit-fn #'n-n))))
|
||||
(apply nfunction args)))))))))
|
||||
|
||||
(defun checking-miss (generic-function args ofunction field cache)
|
||||
(protect-cache-miss-code generic-function args
|
||||
(let* ((arg-info (gf-arg-info generic-function))
|
||||
(nkeys (arg-info-nkeys arg-info)))
|
||||
(multiple-value-bind (wrappers invalidp nfunction)
|
||||
(cache-miss-values generic-function args)
|
||||
(cond (invalidp (apply nfunction args))
|
||||
((null nfunction)
|
||||
(apply #'no-applicable-method generic-function args))
|
||||
((eq ofunction nfunction)
|
||||
(multiple-value-bind (nfield ncache)
|
||||
(fill-cache field cache nkeys nil #'checking-limit-fn wrappers nil)
|
||||
(unless (and (= nfield field)
|
||||
(eq ncache cache))
|
||||
(update-to-checking-dfun generic-function nfunction nfield
|
||||
ncache)))
|
||||
(apply nfunction args))
|
||||
(t (update-to-caching-dfun generic-function)
|
||||
(apply nfunction args)))))))
|
||||
|
||||
(defun caching-miss (generic-function args ofield ocache)
|
||||
(protect-cache-miss-code generic-function args
|
||||
(let* ((arg-info (gf-arg-info generic-function))
|
||||
(nkeys (arg-info-nkeys arg-info)))
|
||||
(multiple-value-bind (wrappers invalidp function)
|
||||
(cache-miss-values generic-function args)
|
||||
(cond (invalidp (apply function args))
|
||||
((null function)
|
||||
(apply #'no-applicable-method generic-function args))
|
||||
(t (multiple-value-bind (nfield ncache)
|
||||
(fill-cache ofield ocache nkeys t #'caching-limit-fn wrappers
|
||||
function)
|
||||
(unless (and (= nfield ofield)
|
||||
(eq ncache ocache))
|
||||
(update-to-caching-dfun generic-function nfield ncache)))
|
||||
(apply function args)))))))
|
||||
|
||||
|
||||
;;; Some useful support functions which are shared by the implementations of the different kinds of
|
||||
;;; dfuns. Given a generic function and a set of arguments to that generic function, returns a mess
|
||||
;;; of values. <wrappers> Is a single wrapper if the generic function has only one key, that is
|
||||
;;; arg-info-nkeys of the arg-info is 1. Otherwise a list of the wrappers of the specialized
|
||||
;;; arguments to the generic function. Note that all these wrappers are valid. This function does
|
||||
;;; invalid wrapper traps when it finds an invalid wrapper and then returns the new, valid wrapper.
|
||||
;;; <invalidp> True if any of the specialized arguments had an invalid wrapper, false otherwise.
|
||||
;;; <function> The compiled effective method function for this set of arguments. Gotten from
|
||||
;;; get-secondary-dispatch-function so effective-method-function caching is in effect, and that is
|
||||
;;; important since it is what keeps us in checking dfun state when possible. <type> READER or
|
||||
;;; WRITER when the only method that would be run is a standard reader or writer method. To be
|
||||
;;; specific, the value is READER when the method combination is eq to
|
||||
;;; *standard-method-combination*; there are no applicable :before, :after or :around methods; and
|
||||
;;; the most specific primary method is a standard reader method. <index> If <type> is READER
|
||||
;;; or WRITER, and the slot accessed is an :instance slot, this is the index number of that slot in
|
||||
;;; the object argument. <applicable> Sorted list of applicable methods.
|
||||
|
||||
|
||||
(defun cache-miss-values (generic-function args)
|
||||
(declare (values wrappers invalidp function applicable))
|
||||
(multiple-value-bind (function appl arg-info)
|
||||
(get-secondary-dispatch-function generic-function args)
|
||||
(multiple-value-bind (wrappers invalidp)
|
||||
(get-wrappers generic-function args arg-info)
|
||||
(values wrappers invalidp (cache-miss-values-function generic-function function)
|
||||
appl))))
|
||||
|
||||
(defun get-wrappers (generic-function args &optional arg-info)
|
||||
(let* ((invalidp nil)
|
||||
(wrappers nil)
|
||||
(arg-info (or arg-info (gf-arg-info generic-function)))
|
||||
(metatypes (arg-info-metatypes arg-info))
|
||||
(nkeys (arg-info-nkeys arg-info)))
|
||||
(flet ((get-valid-wrapper (x)
|
||||
(let ((wrapper (wrapper-of x)))
|
||||
(cond ((invalid-wrapper-p wrapper)
|
||||
(setq invalidp t)
|
||||
(check-wrapper-validity x))
|
||||
(t wrapper)))))
|
||||
(setq wrappers (block collect-wrappers
|
||||
(gathering1 (collecting)
|
||||
(iterate ((arg (list-elements args))
|
||||
(metatype (list-elements metatypes)))
|
||||
(when (neq metatype 't)
|
||||
(if (= nkeys 1)
|
||||
(return-from collect-wrappers
|
||||
(get-valid-wrapper arg))
|
||||
(gather1 (get-valid-wrapper arg))))))))
|
||||
(values wrappers invalidp))))
|
||||
|
||||
(defun cache-miss-values-function (generic-function function)
|
||||
(if (eq *generate-random-code-segments* generic-function)
|
||||
(progn (setq *generate-random-code-segments* nil)
|
||||
#'(lambda (&rest args)
|
||||
(declare (ignore args))
|
||||
nil))
|
||||
function))
|
||||
|
||||
(defun generate-random-code-segments (generic-function)
|
||||
(dolist (arglist (generate-arglists generic-function))
|
||||
(let ((*generate-random-code-segments* generic-function))
|
||||
(apply generic-function arglist))))
|
||||
|
||||
(defun generate-arglists (generic-function)
|
||||
|
||||
;; Generate arglists using class-prototypes and eql-specializer-objects to get all the
|
||||
;; "different" values that could be returned by get-secondary-dispatch-function for this
|
||||
;; generic-function.
|
||||
(let ((methods (generic-function-methods generic-function)))
|
||||
(mapcar #'(lambda (class-list)
|
||||
(mapcar #'(lambda (specializer)
|
||||
(if (eql-specializer-p specializer)
|
||||
(eql-specializer-object specializer)
|
||||
(class-prototype specializer)))
|
||||
(method-specializers (find class-list methods :test
|
||||
#'(lambda (class-list method)
|
||||
(every
|
||||
#'
|
||||
specializer-applicable-using-class-p
|
||||
(method-specializers
|
||||
method)
|
||||
class-list))))))
|
||||
(generate-arglist-classes generic-function))))
|
||||
|
||||
(defun generate-arglist-classes (generic-function)
|
||||
(let ((methods (generic-function-methods generic-function)))
|
||||
(declare (ignore methods))
|
||||
|
||||
;; Finish this sometime.
|
||||
nil))
|
||||
|
||||
(defun accessor-miss-values (generic-function applicable args)
|
||||
(declare (values type index))
|
||||
(let ((type (and (eq (generic-function-method-combination generic-function)
|
||||
*standard-method-combination*)
|
||||
(every #'(lambda (m)
|
||||
(null (method-qualifiers m)))
|
||||
applicable)
|
||||
(let ((method (car applicable)))
|
||||
(cond ((standard-reader-method-p method)
|
||||
(and (optimize-slot-value-by-class-p (class-of (car args))
|
||||
(accessor-method-slot-name method)
|
||||
nil)
|
||||
'reader))
|
||||
((standard-writer-method-p method)
|
||||
(and (optimize-slot-value-by-class-p (class-of (cadr args))
|
||||
(accessor-method-slot-name method)
|
||||
t)
|
||||
'writer))
|
||||
(t nil))))))
|
||||
(values type (and type (let ((wrapper (wrapper-of (case type
|
||||
(reader (car args))
|
||||
(writer (cadr args)))))
|
||||
(slot-name (accessor-method-slot-name (car applicable))))
|
||||
(or (instance-slot-index wrapper slot-name)
|
||||
(assq slot-name (wrapper-class-slots wrapper))))))))
|
||||
@@ -1,492 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
;;; Copyright (c) 1991 by Venue
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
;;;
|
||||
|
||||
(defun emit-one-class-reader (class-slot-p)
|
||||
(emit-reader/writer :reader 1 class-slot-p))
|
||||
|
||||
(defun emit-one-class-writer (class-slot-p)
|
||||
(emit-reader/writer :writer 1 class-slot-p))
|
||||
|
||||
(defun emit-two-class-reader (class-slot-p)
|
||||
(emit-reader/writer :reader 2 class-slot-p))
|
||||
|
||||
(defun emit-two-class-writer (class-slot-p)
|
||||
(emit-reader/writer :writer 2 class-slot-p))
|
||||
|
||||
(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
|
||||
(let ((instance nil)
|
||||
(arglist nil)
|
||||
(closure-variables nil)
|
||||
(field (wrapper-field 'number)))
|
||||
; we need some field to do the fast
|
||||
; obsolete check
|
||||
(ecase reader/writer
|
||||
(:reader (setq instance (dfun-arg-symbol 0)
|
||||
arglist
|
||||
(list instance)))
|
||||
(:writer (setq instance (dfun-arg-symbol 1)
|
||||
arglist
|
||||
(list (dfun-arg-symbol 0)
|
||||
instance))))
|
||||
(ecase 1-or-2-class
|
||||
(1 (setq closure-variables '(wrapper-0 index miss-fn)))
|
||||
(2 (setq closure-variables '(wrapper-0 wrapper-1 index miss-fn))))
|
||||
(generating-lap
|
||||
closure-variables arglist
|
||||
(with-lap-registers ((inst t)
|
||||
; reg for the instance
|
||||
(wrapper vector)
|
||||
; reg for the wrapper
|
||||
(cache-no index))
|
||||
; reg for the cache no
|
||||
(let ((index cache-no)
|
||||
; This register is used for different
|
||||
; values at different times.
|
||||
(slots (and (null class-slot-p)
|
||||
(allocate-register 'vector)))
|
||||
(csv (and class-slot-p (allocate-register t))))
|
||||
(prog1 (flatten-lap (opcode :move (operand :arg instance)
|
||||
inst)
|
||||
; get the instance
|
||||
(opcode :std-instance-p inst 'std-instance)
|
||||
; if not either std-inst
|
||||
(opcode :fsc-instance-p inst 'fsc-instance)
|
||||
; or fsc-instance then
|
||||
(opcode :go 'trap)
|
||||
; we lose
|
||||
(opcode :label 'fsc-instance)
|
||||
(opcode :move (operand :fsc-wrapper inst)
|
||||
wrapper)
|
||||
(and slots (opcode :move (operand :fsc-slots inst)
|
||||
slots))
|
||||
(opcode :go 'have-wrapper)
|
||||
(opcode :label 'std-instance)
|
||||
(opcode :move (operand :std-wrapper inst)
|
||||
wrapper)
|
||||
(and slots (opcode :move (operand :std-slots inst)
|
||||
slots))
|
||||
(opcode :label 'have-wrapper)
|
||||
(opcode :move (operand :cref wrapper field)
|
||||
cache-no)
|
||||
(opcode :izerop cache-no 'trap)
|
||||
; obsolete wrapper?
|
||||
(ecase 1-or-2-class
|
||||
(1 (emit-check-1-class-wrapper wrapper 'wrapper-0
|
||||
'trap))
|
||||
(2 (emit-check-2-class-wrapper wrapper 'wrapper-0
|
||||
'wrapper-1
|
||||
'trap)))
|
||||
(if class-slot-p
|
||||
(flatten-lap (opcode :move (operand :cvar 'index)
|
||||
csv)
|
||||
(ecase reader/writer
|
||||
(:reader (emit-get-class-slot csv 'trap inst))
|
||||
(:writer (emit-set-class-slot csv (car arglist)
|
||||
inst))))
|
||||
(flatten-lap (opcode :move (operand :cvar 'index)
|
||||
index)
|
||||
(ecase reader/writer
|
||||
(:reader (emit-get-slot slots index
|
||||
'trap inst))
|
||||
(:writer (emit-set-slot slots index
|
||||
(car arglist)
|
||||
inst)))))
|
||||
(opcode :label 'trap)
|
||||
(emit-miss 'miss-fn))
|
||||
(when slots (deallocate-register slots))
|
||||
(when csv (deallocate-register csv))))))))
|
||||
|
||||
(defun emit-one-index-readers (class-slot-p)
|
||||
(let ((arglist (list (dfun-arg-symbol 0))))
|
||||
(generating-lap '(field cache mask size index miss-fn)
|
||||
arglist
|
||||
(with-lap-registers ((slots vector))
|
||||
(emit-dlap arglist '(standard-instance)
|
||||
'trap
|
||||
(with-lap-registers ((index index))
|
||||
(flatten-lap (opcode :move (operand :cvar 'index)
|
||||
index)
|
||||
(if class-slot-p
|
||||
(emit-get-class-slot index 'trap slots)
|
||||
(emit-get-slot slots index 'trap))))
|
||||
(flatten-lap (opcode :label 'trap)
|
||||
(emit-miss 'miss-fn))
|
||||
nil
|
||||
(and (null class-slot-p)
|
||||
(list slots)))))))
|
||||
|
||||
(defun emit-one-index-writers (class-slot-p)
|
||||
(let ((arglist (list (dfun-arg-symbol 0)
|
||||
(dfun-arg-symbol 1))))
|
||||
(generating-lap '(field cache mask size index miss-fn)
|
||||
arglist
|
||||
(with-lap-registers ((slots vector))
|
||||
(emit-dlap arglist '(t standard-instance)
|
||||
'trap
|
||||
(with-lap-registers ((index index))
|
||||
(flatten-lap (opcode :move (operand :cvar 'index)
|
||||
index)
|
||||
(if class-slot-p
|
||||
(emit-set-class-slot index (dfun-arg-symbol 0)
|
||||
slots)
|
||||
(emit-set-slot slots index (dfun-arg-symbol 0)))))
|
||||
(flatten-lap (opcode :label 'trap)
|
||||
(emit-miss 'miss-fn))
|
||||
nil
|
||||
(and (null class-slot-p)
|
||||
(list nil slots)))))))
|
||||
|
||||
(defun emit-n-n-readers nil (let ((arglist (list (dfun-arg-symbol 0))))
|
||||
(generating-lap '(field cache mask size miss-fn)
|
||||
arglist
|
||||
(with-lap-registers ((slots vector)
|
||||
(index index))
|
||||
(emit-dlap arglist '(standard-instance)
|
||||
'trap
|
||||
(emit-get-slot slots index 'trap)
|
||||
(flatten-lap (opcode :label 'trap)
|
||||
(emit-miss 'miss-fn))
|
||||
index
|
||||
(list slots))))))
|
||||
|
||||
(defun emit-n-n-writers nil (let ((arglist (list (dfun-arg-symbol 0)
|
||||
(dfun-arg-symbol 1))))
|
||||
(generating-lap '(field cache mask size miss-fn)
|
||||
arglist
|
||||
(with-lap-registers ((slots vector)
|
||||
(index index))
|
||||
(flatten-lap (emit-dlap arglist '(t standard-instance)
|
||||
'trap
|
||||
(emit-set-slot slots index
|
||||
(dfun-arg-symbol 0))
|
||||
(flatten-lap (opcode :label
|
||||
'trap)
|
||||
(emit-miss 'miss-fn))
|
||||
index
|
||||
(list nil slots)))))))
|
||||
|
||||
(defun emit-checking (metatypes applyp)
|
||||
(let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
|
||||
(generating-lap '(field cache mask size function miss-fn)
|
||||
dlap-lambda-list
|
||||
(emit-dlap (remove '&rest dlap-lambda-list)
|
||||
metatypes
|
||||
'trap
|
||||
(with-lap-registers (#'t)
|
||||
(flatten-lap (opcode :move (operand :cvar 'function)
|
||||
function)
|
||||
(opcode :jmp function)))
|
||||
(with-lap-registers ((miss-function t))
|
||||
(flatten-lap (opcode :label 'trap)
|
||||
(opcode :move (operand :cvar 'miss-fn)
|
||||
miss-function)
|
||||
(opcode :jmp miss-function)))
|
||||
nil))))
|
||||
|
||||
(defun emit-caching (metatypes applyp)
|
||||
(let ((dlap-lambda-list (make-dlap-lambda-list metatypes applyp)))
|
||||
(generating-lap '(field cache mask size miss-fn)
|
||||
dlap-lambda-list
|
||||
(with-lap-registers (#'t)
|
||||
(emit-dlap (remove '&rest dlap-lambda-list)
|
||||
metatypes
|
||||
'trap
|
||||
(flatten-lap (opcode :jmp function))
|
||||
(with-lap-registers ((miss-function t))
|
||||
(flatten-lap (opcode :label 'trap)
|
||||
(opcode :move (operand :cvar 'miss-fn)
|
||||
miss-function)
|
||||
(opcode :jmp miss-function)))
|
||||
function)))))
|
||||
|
||||
(defun emit-check-1-class-wrapper (wrapper cwrapper-0 miss-label)
|
||||
(with-lap-registers ((cwrapper vector))
|
||||
(flatten-lap (opcode :move (operand :cvar cwrapper-0)
|
||||
cwrapper)
|
||||
(opcode :neq wrapper cwrapper miss-label))))
|
||||
|
||||
; wrappers not eq, trap
|
||||
|
||||
|
||||
(defun emit-check-2-class-wrapper (wrapper cwrapper-0 cwrapper-1 miss-label)
|
||||
(with-lap-registers ((cwrapper vector))
|
||||
(flatten-lap (opcode :move (operand :cvar cwrapper-0)
|
||||
cwrapper)
|
||||
; This is an OR. Isn't
|
||||
(opcode :eq wrapper cwrapper 'hit-internal)
|
||||
; assembly code fun
|
||||
(opcode :move (operand :cvar cwrapper-1)
|
||||
cwrapper)
|
||||
;
|
||||
(opcode :neq wrapper cwrapper miss-label)
|
||||
;
|
||||
(opcode :label 'hit-internal))))
|
||||
|
||||
(defun emit-get-slot (slots index trap-label &optional temp)
|
||||
(let ((slot-unbound (operand :constant *slot-unbound*)))
|
||||
(with-lap-registers ((val t :reuse temp))
|
||||
(flatten-lap (opcode :move (operand :iref slots index)
|
||||
val)
|
||||
; get slot value
|
||||
(opcode :eq val slot-unbound trap-label)
|
||||
; is the slot unbound?
|
||||
(opcode :return val)))))
|
||||
|
||||
; return the slot value
|
||||
|
||||
|
||||
(defun emit-set-slot (slots index new-value-arg &optional temp)
|
||||
(with-lap-registers ((new-val t :reuse temp))
|
||||
(flatten-lap (opcode :move (operand :arg new-value-arg)
|
||||
new-val)
|
||||
; get new value into a reg
|
||||
(opcode :move new-val (operand :iref slots index))
|
||||
; set slot value
|
||||
(opcode :return new-val))))
|
||||
|
||||
(defun emit-get-class-slot (index trap-label &optional temp)
|
||||
(let ((slot-unbound (operand :constant *slot-unbound*)))
|
||||
(with-lap-registers ((val t :reuse temp))
|
||||
(flatten-lap (opcode :move (operand :cdr index)
|
||||
val)
|
||||
(opcode :eq val slot-unbound trap-label)
|
||||
(opcode :return val)))))
|
||||
|
||||
(defun emit-set-class-slot (index new-value-arg &optional temp)
|
||||
(with-lap-registers ((new-val t :reuse temp))
|
||||
(flatten-lap (opcode :move (operand :arg new-value-arg)
|
||||
new-val)
|
||||
(opcode :move new-val (operand :cdr index))
|
||||
(opcode :return new-val))))
|
||||
|
||||
(defun emit-miss (miss-fn)
|
||||
(with-lap-registers ((miss-fn-reg t))
|
||||
(flatten-lap (opcode :move (operand :cvar miss-fn)
|
||||
miss-fn-reg)
|
||||
; get the miss function
|
||||
(opcode :jmp miss-fn-reg))))
|
||||
|
||||
; and call it
|
||||
|
||||
|
||||
(defun dlap-wrappers (metatypes)
|
||||
(mapcar #'(lambda (x)
|
||||
(and (neq x 't)
|
||||
(allocate-register 'vector)))
|
||||
metatypes))
|
||||
|
||||
(defun dlap-wrapper-moves (wrappers args metatypes miss-label slot-regs)
|
||||
(gathering1 (collecting)
|
||||
(iterate ((mt (list-elements metatypes))
|
||||
(arg (list-elements args))
|
||||
(wrapper (list-elements wrappers))
|
||||
(i (interval :from 0)))
|
||||
(when wrapper
|
||||
(gather1 (emit-fetch-wrapper mt arg wrapper miss-label (nth i slot-regs)))))
|
||||
))
|
||||
|
||||
(defun emit-dlap (args metatypes miss-label hit miss value-reg &optional slot-regs)
|
||||
(let* ((wrappers (dlap-wrappers metatypes))
|
||||
(nwrappers (remove nil wrappers))
|
||||
(wrapper-moves (dlap-wrapper-moves wrappers args metatypes miss-label slot-regs)))
|
||||
(prog1 (emit-dlap-internal nwrappers wrapper-moves hit miss miss-label value-reg)
|
||||
(mapc #'deallocate-register nwrappers))))
|
||||
|
||||
(defun emit-dlap-internal (wrapper-regs wrapper-moves hit miss miss-label value-reg)
|
||||
(cond ((cdr wrapper-regs)
|
||||
(emit-greater-than-1-dlap wrapper-regs wrapper-moves hit miss miss-label value-reg))
|
||||
((null value-reg)
|
||||
(emit-1-nil-dlap (car wrapper-regs)
|
||||
(car wrapper-moves)
|
||||
hit miss miss-label))
|
||||
(t (emit-1-t-dlap (car wrapper-regs)
|
||||
(car wrapper-moves)
|
||||
hit miss miss-label value-reg))))
|
||||
|
||||
(defun emit-1-nil-dlap (wrapper wrapper-move hit miss miss-label)
|
||||
(with-lap-registers ((location index)
|
||||
(primary index)
|
||||
(cache vector))
|
||||
(flatten-lap wrapper-move (opcode :move (operand :cvar 'cache)
|
||||
cache)
|
||||
(with-lap-registers ((wrapper-cache-no index))
|
||||
(flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper
|
||||
primary wrapper-cache-no)
|
||||
(opcode :move primary location)
|
||||
(emit-check-1-wrapper-in-cache cache location wrapper hit)
|
||||
; inline hit code
|
||||
(opcode :izerop wrapper-cache-no miss-label)))
|
||||
(with-lap-registers ((size index))
|
||||
(flatten-lap (opcode :move (operand :cvar 'size)
|
||||
size)
|
||||
(opcode :label 'loop)
|
||||
(opcode :move (operand :i1+ location)
|
||||
location)
|
||||
(opcode :fix= location primary miss-label)
|
||||
(opcode :fix= location size 'set-location-to-min)
|
||||
(opcode :label 'continue)
|
||||
(emit-check-1-wrapper-in-cache cache location wrapper hit)
|
||||
(opcode :go 'loop)
|
||||
(opcode :label 'set-location-to-min)
|
||||
(opcode :izerop primary miss-label)
|
||||
(opcode :move (operand :constant (index-value->index 0))
|
||||
location)
|
||||
(opcode :go 'continue)))
|
||||
miss)))
|
||||
|
||||
|
||||
;;; The function below implements CACHE-LOCK-COUNT as the first entry in a cache (svref cache 0).
|
||||
;;; This should probably be abstracted.
|
||||
|
||||
|
||||
(defun emit-1-t-dlap (wrapper wrapper-move hit miss miss-label value)
|
||||
(with-lap-registers ((location index)
|
||||
(primary index)
|
||||
(cache vector)
|
||||
(initial-lock-count t))
|
||||
(flatten-lap wrapper-move (opcode :move (operand :cvar 'cache)
|
||||
cache)
|
||||
(with-lap-registers ((wrapper-cache-no index))
|
||||
(flatten-lap (emit-1-wrapper-compute-primary-cache-location wrapper
|
||||
primary wrapper-cache-no)
|
||||
(opcode :move primary location)
|
||||
(opcode :move (operand :cref cache 0)
|
||||
initial-lock-count)
|
||||
; get lock-count
|
||||
(emit-check-cache-entry cache location wrapper 'hit-internal)
|
||||
(opcode :izerop wrapper-cache-no miss-label)))
|
||||
; check for obsolescence
|
||||
(with-lap-registers ((size index))
|
||||
(flatten-lap (opcode :move (operand :cvar 'size)
|
||||
size)
|
||||
(opcode :label 'loop)
|
||||
(opcode :move (operand :i1+ location)
|
||||
location)
|
||||
(opcode :move (operand :i1+ location)
|
||||
location)
|
||||
(opcode :label 'continue)
|
||||
(opcode :fix= location primary miss-label)
|
||||
(opcode :fix= location size 'set-location-to-min)
|
||||
(emit-check-cache-entry cache location wrapper 'hit-internal)
|
||||
(opcode :go 'loop)
|
||||
(opcode :label 'set-location-to-min)
|
||||
(opcode :izerop primary miss-label)
|
||||
(opcode :move (operand :constant (index-value->index 2))
|
||||
location)
|
||||
(opcode :go 'continue)))
|
||||
(opcode :label 'hit-internal)
|
||||
(opcode :move (operand :i1+ location)
|
||||
location)
|
||||
; position for getting value
|
||||
(opcode :move (emit-cache-ref cache location)
|
||||
value)
|
||||
(emit-lock-count-test initial-lock-count cache 'hit)
|
||||
miss
|
||||
(opcode :label 'hit)
|
||||
hit)))
|
||||
|
||||
(defun emit-greater-than-1-dlap (wrappers wrapper-moves hit miss miss-label value)
|
||||
(let ((cache-line-size (compute-line-size (+ (length wrappers)
|
||||
(if value
|
||||
1
|
||||
0)))))
|
||||
(with-lap-registers ((location index)
|
||||
(primary index)
|
||||
(cache vector)
|
||||
(initial-lock-count t)
|
||||
(next-location index)
|
||||
(line-size index))
|
||||
; Line size holds a constant that can
|
||||
; be folded in if there was a way to
|
||||
; add a constant to an index register
|
||||
(flatten-lap (apply #'flatten-lap wrapper-moves)
|
||||
(opcode :move (operand :constant cache-line-size)
|
||||
line-size)
|
||||
(opcode :move (operand :cvar 'cache)
|
||||
cache)
|
||||
(emit-n-wrapper-compute-primary-cache-location wrappers primary miss-label)
|
||||
(opcode :move primary location)
|
||||
(opcode :move location next-location)
|
||||
(opcode :move (operand :cref cache 0)
|
||||
initial-lock-count)
|
||||
; get the lock-count
|
||||
(with-lap-registers ((size index))
|
||||
(flatten-lap (opcode :move (operand :cvar 'size)
|
||||
size)
|
||||
(opcode :label 'continue)
|
||||
(opcode :move (operand :i+ location line-size)
|
||||
next-location)
|
||||
(emit-check-cache-line cache location wrappers 'hit)
|
||||
(emit-adjust-location location next-location primary size
|
||||
'continue miss-label)
|
||||
(opcode :label 'hit)
|
||||
(and value (opcode :move (emit-cache-ref cache location)
|
||||
value))
|
||||
(emit-lock-count-test initial-lock-count cache 'hit-internal)
|
||||
miss
|
||||
(opcode :label 'hit-internal)
|
||||
hit))))))
|
||||
|
||||
|
||||
;;; Cache related lap code
|
||||
|
||||
|
||||
(defun emit-check-1-wrapper-in-cache (cache location wrapper hit-code)
|
||||
(let ((exit-emit-check-1-wrapper-in-cache (make-symbol "exit-emit-check-1-wrapper-in-cache")))
|
||||
(with-lap-registers ((cwrapper vector))
|
||||
(flatten-lap (opcode :move (emit-cache-ref cache location)
|
||||
cwrapper)
|
||||
(opcode :neq cwrapper wrapper exit-emit-check-1-wrapper-in-cache)
|
||||
hit-code
|
||||
(opcode :label exit-emit-check-1-wrapper-in-cache)))))
|
||||
|
||||
(defun emit-check-cache-entry (cache location wrapper hit-label)
|
||||
(with-lap-registers ((cwrapper vector))
|
||||
(flatten-lap (opcode :move (emit-cache-ref cache location)
|
||||
cwrapper)
|
||||
(opcode :eq cwrapper wrapper hit-label))))
|
||||
|
||||
(defun emit-check-cache-line (cache location wrappers hit-label)
|
||||
(let ((checks (flatten-lap (gathering1 (flattening-lap)
|
||||
(iterate ((wrapper (list-elements wrappers)))
|
||||
(with-lap-registers ((cwrapper vector))
|
||||
(gather1 (flatten-lap (opcode :move
|
||||
(emit-cache-ref
|
||||
cache location)
|
||||
cwrapper)
|
||||
(opcode :neq cwrapper wrapper
|
||||
|
||||
'
|
||||
exit-emit-check-cache-line
|
||||
)
|
||||
(opcode :move (operand :i1+
|
||||
location)
|
||||
location)))))))))
|
||||
(flatten-lap checks (opcode :go hit-label)
|
||||
(opcode :label 'exit-emit-check-cache-line))))
|
||||
|
||||
(defun emit-lock-count-test (initial-lock-count cache hit-label)
|
||||
|
||||
;; jumps to hit-label if cache-lock-count consistent, otherwise, continues
|
||||
(with-lap-registers ((new-lock-count t))
|
||||
(flatten-lap (opcode :move (operand :cref cache 0)
|
||||
new-lock-count)
|
||||
; get new cache-lock-count
|
||||
(opcode :fix= new-lock-count initial-lock-count hit-label))))
|
||||
|
||||
(defun emit-adjust-location (location next-location primary size cont-label miss-label)
|
||||
(flatten-lap (opcode :move next-location location)
|
||||
(opcode :fix= location size 'at-end-of-cache)
|
||||
(opcode :fix= location primary miss-label)
|
||||
(opcode :go cont-label)
|
||||
(opcode :label 'at-end-of-cache)
|
||||
(opcode :fix= primary (operand :constant (index-value->index 1))
|
||||
miss-label)
|
||||
(opcode :move (operand :constant (index-value->index 1))
|
||||
location)
|
||||
(opcode :go cont-label)))
|
||||
@@ -1,200 +0,0 @@
|
||||
;;;-*-Mode:LISP; Package:(CLOS (LISP WALKER)); Base:10; Syntax:Common-lisp -*-
|
||||
;;;
|
||||
;;; *************************************************************************
|
||||
;;; Copyright (c) 1991 Venue
|
||||
;;; All rights reserved.
|
||||
;;; *************************************************************************
|
||||
;;;
|
||||
;;; Basic environmental stuff.
|
||||
;;;
|
||||
|
||||
(in-package 'clos)
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;;
|
||||
;;;
|
||||
|
||||
(defgeneric describe-object (object stream))
|
||||
|
||||
|
||||
(defmethod describe-object ((object standard-object) stream)
|
||||
(let* ((class (class-of object))
|
||||
(slotds (slots-to-inspect class object))
|
||||
(max-slot-name-length 0)
|
||||
(instance-slotds ())
|
||||
(class-slotds ())
|
||||
(other-slotds ()))
|
||||
(flet ((adjust-slot-name-length (name)
|
||||
(setq max-slot-name-length
|
||||
(max max-slot-name-length
|
||||
(length (the string (symbol-name name))))))
|
||||
(describe-slot (name value &optional (allocation () alloc-p))
|
||||
(if alloc-p
|
||||
(format stream
|
||||
"~% ~A ~S ~VT ~S"
|
||||
name allocation (+ max-slot-name-length 7) value)
|
||||
(format stream
|
||||
"~% ~A~VT ~S"
|
||||
name max-slot-name-length value))))
|
||||
;; Figure out a good width for the slot-name column.
|
||||
(dolist (slotd slotds)
|
||||
(adjust-slot-name-length (slotd-name slotd))
|
||||
(case (slotd-allocation slotd)
|
||||
(:instance (push slotd instance-slotds))
|
||||
(:class (push slotd class-slotds))
|
||||
(otherwise (push slotd other-slotds))))
|
||||
(setq max-slot-name-length (min (+ max-slot-name-length 3) 30))
|
||||
(format stream "~%~S is an instance of class ~S:" object class)
|
||||
|
||||
(when instance-slotds
|
||||
(format stream "~% The following slots have :INSTANCE allocation:")
|
||||
(dolist (slotd (nreverse instance-slotds))
|
||||
(describe-slot (slotd-name slotd)
|
||||
(slot-value-or-default object (slotd-name slotd)))))
|
||||
|
||||
(when class-slotds
|
||||
(format stream "~% The following slots have :CLASS allocation:")
|
||||
(dolist (slotd (nreverse class-slotds))
|
||||
(describe-slot (slotd-name slotd)
|
||||
(slot-value-or-default object (slotd-name slotd)))))
|
||||
|
||||
(when other-slotds
|
||||
(format stream "~% The following slots have allocation as shown:")
|
||||
(dolist (slotd (nreverse other-slotds))
|
||||
(describe-slot (slotd-name slotd)
|
||||
(slot-value-or-default object (slotd-name slotd))
|
||||
(slotd-allocation slotd))))
|
||||
(values))))
|
||||
|
||||
(defmethod slots-to-inspect ((class std-class) (object standard-object))
|
||||
(class-slots class))
|
||||
|
||||
;;;
|
||||
;;;
|
||||
;;;
|
||||
(defmethod describe-object ((class class) stream)
|
||||
(flet ((pretty-class (c) (or (class-name c) c)))
|
||||
(macrolet ((ft (string &rest args) `(format stream ,string ,@args)))
|
||||
(ft "~&~S is a class, it is an instance of ~S.~%"
|
||||
class (pretty-class (class-of class)))
|
||||
(let ((name (class-name class)))
|
||||
(if name
|
||||
(if (eq class (find-class name nil))
|
||||
(ft "Its proper name is ~S.~%" name)
|
||||
(ft "Its name is ~S, but this is not a proper name.~%" name))
|
||||
(ft "It has no name (the name is NIL).~%")))
|
||||
(ft "The direct superclasses are: ~:S, and the direct~%~
|
||||
subclasses are: ~:S. The class precedence list is:~%~S~%~
|
||||
There are ~D methods specialized for this class."
|
||||
(mapcar #'pretty-class (class-direct-superclasses class))
|
||||
(mapcar #'pretty-class (class-direct-subclasses class))
|
||||
(mapcar #'pretty-class (class-precedence-list class))
|
||||
(length (specializer-methods class))))))
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;; trace-method and untrace-method accept method specs as arguments. A
|
||||
;;; method-spec should be a list like:
|
||||
;;; (<generic-function-spec> qualifiers* (specializers*))
|
||||
;;; where <generic-function-spec> should be either a symbol or a list
|
||||
;;; of (SETF <symbol>).
|
||||
;;;
|
||||
;;; For example, to trace the method defined by:
|
||||
;;;
|
||||
;;; (defmethod foo ((x spaceship)) 'ss)
|
||||
;;;
|
||||
;;; You should say:
|
||||
;;;
|
||||
;;; (trace-method '(foo (spaceship)))
|
||||
;;;
|
||||
;;; You can also provide a method object in the place of the method
|
||||
;;; spec, in which case that method object will be traced.
|
||||
;;;
|
||||
;;; For untrace-method, if an argument is given, that method is untraced.
|
||||
;;; If no argument is given, all traced methods are untraced.
|
||||
;;;
|
||||
(defclass traced-method (method)
|
||||
((method :initarg :method)
|
||||
(function :initarg :function
|
||||
:reader method-function)
|
||||
(generic-function :initform nil
|
||||
:accessor method-generic-function)))
|
||||
|
||||
(defmethod method-lambda-list ((m traced-method))
|
||||
(with-slots (method) m (method-lambda-list method)))
|
||||
|
||||
(defmethod method-specializers ((m traced-method))
|
||||
(with-slots (method) m (method-specializers method)))
|
||||
|
||||
(defmethod method-qualifiers ((m traced-method))
|
||||
(with-slots (method) m (method-qualifiers method)))
|
||||
|
||||
(defmethod method-qualifiers ((m traced-method))
|
||||
(with-slots (method) m (method-qualifiers method)))
|
||||
|
||||
(defmethod accessor-method-slot-name ((m traced-method))
|
||||
(with-slots (method) m (accessor-method-slot-name method)))
|
||||
|
||||
(defvar *traced-methods* ())
|
||||
|
||||
(defun trace-method (spec &rest options)
|
||||
(multiple-value-bind (gf omethod name)
|
||||
(parse-method-or-spec spec)
|
||||
(let* ((tfunction (trace-method-internal (method-function omethod)
|
||||
name
|
||||
options))
|
||||
(tmethod (make-instance 'traced-method
|
||||
:method omethod
|
||||
:function tfunction)))
|
||||
(remove-method gf omethod)
|
||||
(add-method gf tmethod)
|
||||
(pushnew tmethod *traced-methods*)
|
||||
tmethod)))
|
||||
|
||||
(defun untrace-method (&optional spec)
|
||||
(flet ((untrace-1 (m)
|
||||
(let ((gf (method-generic-function m)))
|
||||
(when gf
|
||||
(remove-method gf m)
|
||||
(add-method gf (slot-value m 'method))
|
||||
(setq *traced-methods* (remove m *traced-methods*))))))
|
||||
(if (not (null spec))
|
||||
(multiple-value-bind (gf method)
|
||||
(parse-method-or-spec spec)
|
||||
(declare (ignore gf))
|
||||
(if (memq method *traced-methods*)
|
||||
(untrace-1 method)
|
||||
(error "~S is not a traced method?" method)))
|
||||
(dolist (m *traced-methods*) (untrace-1 m)))))
|
||||
|
||||
(defun trace-method-internal (ofunction name options)
|
||||
(eval `(untrace ,name))
|
||||
(setf (symbol-function name) ofunction)
|
||||
(eval `(trace ,name ,@options))
|
||||
(symbol-function name))
|
||||
|
||||
|
||||
|
||||
|
||||
;(defun compile-method (spec)
|
||||
; (multiple-value-bind (gf method name)
|
||||
; (parse-method-or-spec spec)
|
||||
; (declare (ignore gf))
|
||||
; (compile name (method-function method))
|
||||
; (setf (method-function method) (symbol-function name))))
|
||||
|
||||
(defmacro undefmethod (&rest args)
|
||||
#+(or (not :lucid) :lcl3.0)
|
||||
(declare (arglist name {method-qualifier}* specializers))
|
||||
`(undefmethod-1 ',args))
|
||||
|
||||
(defun undefmethod-1 (args)
|
||||
(multiple-value-bind (gf method)
|
||||
(parse-method-or-spec args)
|
||||
(when (and gf method)
|
||||
(remove-method gf method)
|
||||
method)))
|
||||
|
||||
@@ -1,235 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
|
||||
;;; File converted on 26-Mar-91 10:33:34 from source fin
|
||||
;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>fin.;3 created 19-Feb-91 16:21:49
|
||||
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
|
||||
|
||||
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
;;; Shadow, Export, Require, Use-package, and Import forms should follow here
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
;;
|
||||
|
||||
|
||||
|
||||
;;; FUNCALLABLE INSTANCES
|
||||
|
||||
|
||||
|
||||
;;
|
||||
|
||||
|
||||
|
||||
;;; The first part of the file contains the implementation dependent code to implement funcallable
|
||||
;;; instances. Each implementation must provide the following functions and macros:
|
||||
;;; ALLOCATE-FUNCALLABLE-INSTANCE-1 () should create and return a new funcallable instance. The
|
||||
;;; funcallable-instance-data slots must be initialized to NIL. This is called by
|
||||
;;; allocate-funcallable-instance and by the bootstrapping code. FUNCALLABLE-INSTANCE-P (x) the
|
||||
;;; obvious predicate. This should be an INLINE function. it must be funcallable, but it would be
|
||||
;;; nice if it compiled open. SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value) change the fin so
|
||||
;;; that when it is funcalled, the new-value function is called. Note that it is legal for
|
||||
;;; new-value to be copied before it is installed in the fin, specifically there is no accessor for
|
||||
;;; a FIN's function so this function does not have to preserve the actual new value. The new-value
|
||||
;;; argument can be any funcallable thing, a closure, lambda compiled code etc. This function must
|
||||
;;; coerce those values if necessary. NOTE: new-value is almost always a compiled closure. This is
|
||||
;;; the important case to optimize. FUNCALLABLE-INSTANCE-DATA-1 (fin data-name) should return the
|
||||
;;; value of the data named data-name in the fin. data-name is one of the symbols in the list which
|
||||
;;; is the value of funcallable-instance-data. Since data-name is almost always a quoted symbol and
|
||||
;;; funcallable-instance-data is a constant, it is possible (and worthwhile) to optimize the
|
||||
;;; computation of data-name's offset in the data part of the fin. This must be SETF'able.
|
||||
|
||||
|
||||
(defconstant funcallable-instance-data '(wrapper slots)
|
||||
"These are the 'data-slots' which funcallable instances have so that
|
||||
the meta-class funcallable-standard-class can store class, and static
|
||||
slots in them.")
|
||||
|
||||
(defmacro funcallable-instance-data-position (data)
|
||||
(if (and (consp data)
|
||||
(eq (car data)
|
||||
'quote)
|
||||
(boundp 'funcallable-instance-data))
|
||||
(or (position (cadr data)
|
||||
funcallable-instance-data :test #'eq)
|
||||
(progn (warn "Unknown funcallable-instance data: ~S." (cadr data))
|
||||
`(error "Unknown funcallable-instance data: ~S." ',(cadr data))))
|
||||
`(position ,data funcallable-instance-data :test #'eq)))
|
||||
|
||||
(defun called-fin-without-function nil (error "Attempt to funcall a funcallable-instance without first~%~
|
||||
setting its funcallable-instance-function."))
|
||||
|
||||
|
||||
;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and CCODEP. The environment
|
||||
;;; is represented as a block. There is space in the top 8 bits of the pointers to the CCODE and
|
||||
;;; the environment to use to mark the closure as being a FIN. To help the debugger figure out when
|
||||
;;; it has found a FIN on the stack, we reserve the last element of the closure environment to use
|
||||
;;; to point back to the actual fin. Note that there is code in xerox-low which lets us access the
|
||||
;;; fields of compiled-closures and which defines the closure-overlay record. That code is there
|
||||
;;; because there are some clients of it in that file.
|
||||
|
||||
|
||||
|
||||
;; Don't be fooled. We actually allocate one bigger than this to have a place to store the
|
||||
;; backpointer to the fin. -smL
|
||||
|
||||
|
||||
(defconstant funcallable-instance-closure-size 15)
|
||||
|
||||
(defvar *fin-env-type* (type-of (il:\\allocblock (1+ funcallable-instance-closure-size)
|
||||
t)))
|
||||
|
||||
|
||||
;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL
|
||||
|
||||
|
||||
(defstruct fin-env-pointer (pointer nil :type il:fullxpointer))
|
||||
|
||||
(defun fin-env-fin (fin-env)
|
||||
(fin-env-pointer-pointer (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2))))
|
||||
|
||||
(defun |set fin-env-fin| (fin-env new-value)
|
||||
(il:\\rplptr fin-env (* funcallable-instance-closure-size 2)
|
||||
(make-fin-env-pointer :pointer new-value))
|
||||
new-value)
|
||||
|
||||
(defsetf fin-env-fin |set fin-env-fin|)
|
||||
|
||||
|
||||
;; The finalization function that will clean up the backpointer from the fin-env to the fin. This
|
||||
;; needs to be careful to not cons at all. This depends on there being no other finalization
|
||||
;; function on compiled-closures, since there is only one finalization function per datatype. Too
|
||||
;; bad. -smL
|
||||
|
||||
|
||||
(defun finalize-fin (fin)
|
||||
|
||||
;; This could use the fn funcallable-instance-p, but if we get here we know that this is a
|
||||
;; closure, so we can skip that test.
|
||||
(when (il:fetch (closure-overlay funcallable-instance-p)
|
||||
il:of fin)
|
||||
(let ((env (il:fetch (il:compiled-closure il:environment)
|
||||
il:of fin)))
|
||||
(when env
|
||||
(setq env (il:\\getbaseptr env (* funcallable-instance-closure-size 2)))
|
||||
(when (typep env 'fin-env-pointer)
|
||||
(setf (fin-env-pointer-pointer env)
|
||||
nil)))))
|
||||
nil)
|
||||
|
||||
(eval-when (load)
|
||||
|
||||
;; Install the above finalization function.
|
||||
(when (fboundp 'finalize-fin)
|
||||
(il:\\set.finalization.function 'il:compiled-closure 'finalize-fin)))
|
||||
|
||||
(defun allocate-funcallable-instance-1 nil (let* ((env (il:\\allocblock (1+
|
||||
funcallable-instance-closure-size
|
||||
)
|
||||
t))
|
||||
(fin (il:make-compiled-closure nil env)))
|
||||
(setf (fin-env-fin env)
|
||||
fin)
|
||||
(il:replace (closure-overlay funcallable-instance-p)
|
||||
il:of fin il:with 't)
|
||||
(set-funcallable-instance-function
|
||||
fin
|
||||
#'(lambda (&rest ignore)
|
||||
(declare (ignore ignore))
|
||||
(called-fin-without-function)))
|
||||
fin))
|
||||
|
||||
(xcl:definline funcallable-instance-p (x)
|
||||
(and (typep x 'il:compiled-closure)
|
||||
(il:fetch (closure-overlay funcallable-instance-p)
|
||||
il:of x)))
|
||||
|
||||
(defun set-funcallable-instance-function (fin new)
|
||||
(cond ((not (funcallable-instance-p fin))
|
||||
(error "~S is not a funcallable-instance" fin))
|
||||
((not (functionp new))
|
||||
(error "~S is not a function." new))
|
||||
((typep new 'il:compiled-closure)
|
||||
(let* ((fin-env (il:fetch (il:compiled-closure il:environment)
|
||||
il:of fin))
|
||||
(new-env (il:fetch (il:compiled-closure il:environment)
|
||||
il:of new))
|
||||
(new-env-size (if new-env
|
||||
(il:\\#blockdatacells new-env)
|
||||
0))
|
||||
(fin-env-size (- funcallable-instance-closure-size (length
|
||||
funcallable-instance-data
|
||||
))))
|
||||
(cond ((and new-env (<= new-env-size fin-env-size))
|
||||
(dotimes (i fin-env-size)
|
||||
(il:\\rplptr fin-env (* i 2)
|
||||
(if (< i new-env-size)
|
||||
(il:\\getbaseptr new-env (* i 2))
|
||||
nil)))
|
||||
(setf (compiled-closure-fnheader fin)
|
||||
(compiled-closure-fnheader new)))
|
||||
(t (set-funcallable-instance-function fin (make-trampoline new))))))
|
||||
(t (set-funcallable-instance-function fin (make-trampoline new)))))
|
||||
|
||||
(defun make-trampoline (function)
|
||||
#'(lambda (&rest args)
|
||||
(apply function args)))
|
||||
|
||||
(defmacro funcallable-instance-data-1 (fin data)
|
||||
`(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment)
|
||||
il:of
|
||||
,fin)
|
||||
(* (- funcallable-instance-closure-size (funcallable-instance-data-position
|
||||
,data)
|
||||
1)
|
||||
; Reserve last element to point back to
|
||||
; actual FIN!
|
||||
2)))
|
||||
|
||||
(defsetf funcallable-instance-data-1 (fin data)
|
||||
(new-value)
|
||||
`(il:\\rplptr (il:fetch (il:compiled-closure il:environment)
|
||||
il:of
|
||||
,fin)
|
||||
(* (- funcallable-instance-closure-size (funcallable-instance-data-position
|
||||
,data)
|
||||
1)
|
||||
2)
|
||||
,new-value))
|
||||
|
||||
; end of #+Xerox
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
(defmacro fsc-instance-p (fin)
|
||||
`(funcallable-instance-p ,fin))
|
||||
|
||||
(defmacro fsc-instance-class (fin)
|
||||
`(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))
|
||||
|
||||
(defmacro fsc-instance-wrapper (fin)
|
||||
`(funcallable-instance-data-1 ,fin 'wrapper))
|
||||
|
||||
(defmacro fsc-instance-slots (fin)
|
||||
`(funcallable-instance-data-1 ,fin 'slots))
|
||||
|
||||
(defun allocate-funcallable-instance (wrapper number-of-static-slots)
|
||||
(let ((fin (allocate-funcallable-instance-1))
|
||||
(slots (%allocate-static-slot-storage--class number-of-static-slots)))
|
||||
(setf (fsc-instance-wrapper fin)
|
||||
wrapper
|
||||
(fsc-instance-slots fin)
|
||||
slots)
|
||||
fin))
|
||||
@@ -1,15 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
|
||||
(eval-when (compile load eval)
|
||||
(fix-early-generic-functions)
|
||||
(setq *boot-state* 'complete))
|
||||
|
||||
(defun print-std-instance (instance stream depth)
|
||||
(declare (ignore depth))
|
||||
(print-object instance stream))
|
||||
@@ -1,172 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
|
||||
|
||||
;;; GET-FUNCTION is the main user interface to this code. If it is called with a lambda expression
|
||||
;;; only, it will return a corresponding function. The optional constant-converter argument, can be
|
||||
;;; a function which will be called to convert each constant appearing in the lambda to whatever
|
||||
;;; value should appear in the function. Whether the returned function is actually compiled depends
|
||||
;;; on whether the compiler is present (see COMPILE-LAMBDA) and whether this shape of code was
|
||||
;;; precompiled.
|
||||
|
||||
|
||||
(defun get-function (lambda &optional (test-converter #'default-test-converter)
|
||||
(code-converter #'default-code-converter)
|
||||
(constant-converter #'default-constant-converter))
|
||||
(apply (get-function-generator lambda test-converter code-converter)
|
||||
(compute-constants lambda constant-converter)))
|
||||
|
||||
(defun default-test-converter (form)
|
||||
(if (not (constantp form))
|
||||
form
|
||||
'.constant.))
|
||||
|
||||
(defun default-code-converter (form)
|
||||
(if (not (constantp form))
|
||||
form
|
||||
(let ((gensym (gensym)))
|
||||
(values gensym (list gensym)))))
|
||||
|
||||
(defun default-constant-converter (form)
|
||||
(and (constantp form)
|
||||
(list (if (and (consp form)
|
||||
(eq (car form)
|
||||
'quote))
|
||||
; This had better
|
||||
(cadr form)
|
||||
; do the same as
|
||||
form))))
|
||||
|
||||
; EVAL would have.
|
||||
|
||||
|
||||
|
||||
;;; *fgens* is a list of all the function generators we have so far. Each element is a FGEN
|
||||
;;; structure as implemented below. Don't ever touch this list by hand, use STORE-FGEN.
|
||||
|
||||
|
||||
(defvar *fgens* nil)
|
||||
|
||||
(defun store-fgen (fgen)
|
||||
(setq *fgens* (nconc *fgens* (list fgen))))
|
||||
|
||||
(defun lookup-fgen (test)
|
||||
(find test (the list *fgens*)
|
||||
:key
|
||||
#'fgen-test :test #'equal))
|
||||
|
||||
(defun make-fgen (test gensyms generator generator-lambda system)
|
||||
(let ((new (make-array 6)))
|
||||
(setf (svref new 0)
|
||||
test
|
||||
(svref new 1)
|
||||
gensyms
|
||||
(svref new 2)
|
||||
generator
|
||||
(svref new 3)
|
||||
generator-lambda
|
||||
(svref new 4)
|
||||
system)
|
||||
new))
|
||||
|
||||
(defun fgen-test (fgen)
|
||||
(svref fgen 0))
|
||||
|
||||
(defun fgen-gensyms (fgen)
|
||||
(svref fgen 1))
|
||||
|
||||
(defun fgen-generator (fgen)
|
||||
(svref fgen 2))
|
||||
|
||||
(defun fgen-generator-lambda (fgen)
|
||||
(svref fgen 3))
|
||||
|
||||
(defun fgen-system (fgen)
|
||||
(svref fgen 4))
|
||||
|
||||
(defun get-function-generator (lambda test-converter code-converter)
|
||||
(let* ((test (compute-test lambda test-converter))
|
||||
(fgen (lookup-fgen test)))
|
||||
(if fgen
|
||||
(fgen-generator fgen)
|
||||
(get-new-function-generator lambda test code-converter))))
|
||||
|
||||
(defun get-new-function-generator (lambda test code-converter)
|
||||
(multiple-value-bind (gensyms generator-lambda)
|
||||
(get-new-function-generator-internal lambda code-converter)
|
||||
(let* ((generator (compile-lambda generator-lambda))
|
||||
(fgen (make-fgen test gensyms generator generator-lambda nil)))
|
||||
(store-fgen fgen)
|
||||
generator)))
|
||||
|
||||
(defun get-new-function-generator-internal (lambda code-converter)
|
||||
(multiple-value-bind (code gensyms)
|
||||
(compute-code lambda code-converter)
|
||||
(values gensyms `(lambda ,gensyms #',code))))
|
||||
|
||||
(defun compute-test (lambda test-converter)
|
||||
(walk-form lambda nil #'(lambda (f c e)
|
||||
(declare (ignore e))
|
||||
(if (neq c :eval)
|
||||
f
|
||||
(let ((converted (funcall test-converter f)))
|
||||
(values converted (neq converted f)))))))
|
||||
|
||||
(defun compute-code (lambda code-converter)
|
||||
(let ((gensyms nil))
|
||||
(values (walk-form lambda nil #'(lambda (f c e)
|
||||
(declare (ignore e))
|
||||
(if (neq c :eval)
|
||||
f
|
||||
(multiple-value-bind
|
||||
(converted gens)
|
||||
(funcall code-converter f)
|
||||
(when gens
|
||||
(setq gensyms (append gensyms gens)))
|
||||
(values converted (neq converted f))))))
|
||||
gensyms)))
|
||||
|
||||
(defun compute-constants (lambda constant-converter)
|
||||
(macrolet ((appending nil `(let ((result nil))
|
||||
(values #'(lambda (value)
|
||||
(setq result (append result value)))
|
||||
#'(lambda nil result)))))
|
||||
(gathering1 (appending)
|
||||
(walk-form lambda nil #'(lambda (f c e)
|
||||
(declare (ignore e))
|
||||
(if (neq c :eval)
|
||||
f
|
||||
(let ((consts (funcall constant-converter f))
|
||||
)
|
||||
(if consts
|
||||
(progn (gather1 consts)
|
||||
(values f t))
|
||||
f))))))))
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
(defmacro
|
||||
precompile-function-generators
|
||||
(&optional system)
|
||||
(make-top-level-form
|
||||
`(precompile-function-generators ,system)
|
||||
'(load)
|
||||
`(progn ,@(gathering1 (collecting)
|
||||
(dolist (fgen *fgens*)
|
||||
(when (or (null (fgen-system fgen))
|
||||
(eq (fgen-system fgen)
|
||||
system))
|
||||
(gather1 `(load-function-generator ',(fgen-test fgen)
|
||||
',(fgen-gensyms fgen)
|
||||
#',(fgen-generator-lambda fgen)
|
||||
',(fgen-generator-lambda fgen)
|
||||
',system))))))))
|
||||
|
||||
(defun load-function-generator (test gensyms generator generator-lambda system)
|
||||
(store-fgen (make-fgen test gensyms generator generator-lambda system)))
|
||||
@@ -1,72 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
|
||||
;;; This file contains the
|
||||
;;; definition of the FUNCALLABLE-STANDARD-CLASS metaclass. Much of the implementation of this
|
||||
;;; metaclass is actually defined on the class STD-CLASS. What appears in this file is a modest
|
||||
;;; number of simple methods related to the low-level differences in the implementation of standard
|
||||
;;; and funcallable-standard instances. As it happens, none of these differences are the ones
|
||||
;;; reflected in the MOP specification; STANDARD-CLASS and FUNCALLABLE-STANDARD-CLASS share all
|
||||
;;; their specified methods at STD-CLASS. workings of this metaclass and the standard-class
|
||||
;;; metaclass.
|
||||
|
||||
|
||||
(defmethod wrapper-fetcher ((class funcallable-standard-class))
|
||||
'fsc-instance-wrapper)
|
||||
|
||||
(defmethod slots-fetcher ((class funcallable-standard-class))
|
||||
'fsc-instance-slots)
|
||||
|
||||
(defmethod raw-instance-allocator ((class funcallable-standard-class))
|
||||
'allocate-funcallable-instance-1)
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
(defmethod check-super-metaclass-compatibility ((fsc funcallable-standard-class)
|
||||
(class standard-class))
|
||||
(null (wrapper-instance-slots-layout (class-wrapper class))))
|
||||
|
||||
(defmethod allocate-instance ((class funcallable-standard-class)
|
||||
&rest initargs)
|
||||
(declare (ignore initargs))
|
||||
(unless (class-finalized-p class)
|
||||
(finalize-inheritance class))
|
||||
(let ((class-wrapper (class-wrapper class)))
|
||||
(allocate-funcallable-instance class-wrapper (class-no-of-instance-slots class))))
|
||||
|
||||
(defmethod make-reader-method-function ((class funcallable-standard-class)
|
||||
slot-name)
|
||||
(make-std-reader-method-function slot-name))
|
||||
|
||||
(defmethod make-writer-method-function ((class funcallable-standard-class)
|
||||
slot-name)
|
||||
(make-std-writer-method-function slot-name))
|
||||
|
||||
; See the comment about
|
||||
; reader-function--std and
|
||||
; writer-function--sdt.
|
||||
; (define-function-template
|
||||
; reader-function--fsc () '(slot-name)
|
||||
; `(function (lambda (instance)
|
||||
; (slot-value-using-class
|
||||
; (wrapper-class (get-wrapper
|
||||
; instance)) instance slot-name))))
|
||||
; (define-function-template
|
||||
; writer-function--fsc () '(slot-name)
|
||||
; `(function (lambda (nv instance)
|
||||
; (setf (slot-value-using-class
|
||||
; (wrapper-class (get-wrapper
|
||||
; instance)) instance slot-name) nv))))
|
||||
; (eval-when (load)
|
||||
; (pre-make-templated-function-constructor
|
||||
; reader-function--fsc)
|
||||
; (pre-make-templated-function-constructor
|
||||
; writer-function--fsc))
|
||||
|
||||
@@ -1,183 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
;;; this file defines the
|
||||
;;; initialization and related protocols.
|
||||
|
||||
|
||||
(defmethod make-instance ((class std-class)
|
||||
&rest initargs)
|
||||
(unless (class-finalized-p class)
|
||||
(finalize-inheritance class))
|
||||
(setq initargs (default-initargs class initargs))
|
||||
(when initargs
|
||||
(when (and (eq *boot-state* 'complete)
|
||||
(let ((tail initargs))
|
||||
(loop (unless tail (return t))
|
||||
(when (eq (car tail)
|
||||
':allow-other-keys)
|
||||
(return nil))
|
||||
(setq tail (cddr tail)))))
|
||||
(check-initargs-1 class initargs (append (compute-applicable-methods
|
||||
#'allocate-instance (list class))
|
||||
(compute-applicable-methods
|
||||
#'initialize-instance
|
||||
(list (class-prototype class)))
|
||||
(compute-applicable-methods
|
||||
#'shared-initialize
|
||||
(list (class-prototype class)
|
||||
t))))))
|
||||
(let ((instance (apply #'allocate-instance class initargs)))
|
||||
(apply #'initialize-instance instance initargs)
|
||||
instance))
|
||||
|
||||
(defmethod make-instance ((class-name symbol)
|
||||
&rest initargs)
|
||||
(apply #'make-instance (find-class class-name)
|
||||
initargs))
|
||||
|
||||
(defvar *default-initargs-flag* (list nil))
|
||||
|
||||
(defmethod default-initargs ((class std-class)
|
||||
supplied-initargs)
|
||||
|
||||
;; This implementation of default initargs is critically dependent on all-default-initargs
|
||||
;; not having any duplicate initargs in it.
|
||||
(let ((all-default (class-default-initargs class))
|
||||
(miss *default-initargs-flag*))
|
||||
(flet ((getf* (plist key)
|
||||
(do nil
|
||||
((null plist)
|
||||
miss)
|
||||
(if (eq (car plist)
|
||||
key)
|
||||
(return (cadr plist))
|
||||
(setq plist (cddr plist))))))
|
||||
(labels ((default-1 (tail)
|
||||
(if (null tail)
|
||||
nil
|
||||
(if (eq (getf* supplied-initargs (caar tail))
|
||||
miss)
|
||||
(list* (caar tail)
|
||||
(funcall (cadar tail))
|
||||
(default-1 (cdr tail)))
|
||||
(default-1 (cdr tail))))))
|
||||
(append supplied-initargs (default-1 all-default))))))
|
||||
|
||||
(defmethod initialize-instance ((instance standard-object)
|
||||
&rest initargs)
|
||||
(apply #'shared-initialize instance t initargs))
|
||||
|
||||
(defmethod reinitialize-instance ((instance standard-object)
|
||||
&rest initargs)
|
||||
(when initargs
|
||||
(when (eq *boot-state* 'complete)
|
||||
(check-initargs-1 (class-of instance)
|
||||
initargs
|
||||
(append (compute-applicable-methods #'reinitialize-instance (list instance))
|
||||
(compute-applicable-methods #'shared-initialize (list instance t))))))
|
||||
(apply #'shared-initialize instance nil initargs)
|
||||
instance)
|
||||
|
||||
(defmethod update-instance-for-different-class ((previous standard-object)
|
||||
(current standard-object)
|
||||
&rest initargs)
|
||||
(when initargs
|
||||
(check-initargs-1 (class-of current)
|
||||
initargs
|
||||
(append (compute-applicable-methods #'update-instance-for-different-class
|
||||
(list previous current))
|
||||
(compute-applicable-methods #'shared-initialize (list current t)))))
|
||||
|
||||
;; First we must compute the newly added slots. The spec defines newly added slots as "those
|
||||
;; local slots for which no slot of the same name exists in the previous class."
|
||||
(let ((added-slots 'nil)
|
||||
(current-slotds (class-slots (class-of current)))
|
||||
(previous-slot-names (mapcar #'slotd-name (class-slots (class-of previous)))))
|
||||
(dolist (slotd current-slotds)
|
||||
(if (and (not (memq (slotd-name slotd)
|
||||
previous-slot-names))
|
||||
(eq (slotd-allocation slotd)
|
||||
':instance))
|
||||
(push (slotd-name slotd)
|
||||
added-slots)))
|
||||
(apply #'shared-initialize current added-slots initargs)))
|
||||
|
||||
(defmethod update-instance-for-redefined-class ((instance standard-object)
|
||||
added-slots discarded-slots property-list &rest
|
||||
initargs)
|
||||
(declare (ignore discarded-slots property-list))
|
||||
(when initargs
|
||||
(check-initargs-1 (class-of instance)
|
||||
initargs
|
||||
(append (compute-applicable-methods #'update-instance-for-redefined-class
|
||||
(list instance))
|
||||
(compute-applicable-methods #'shared-initialize (list instance nil)))))
|
||||
(apply #'shared-initialize instance added-slots initargs))
|
||||
|
||||
(defmethod shared-initialize ((instance standard-object)
|
||||
slot-names &rest initargs)
|
||||
|
||||
;; initialize the instance's slots in a two step process 1) A slot for which one of the
|
||||
;; initargs in initargs can set the slot, should be set by that initarg. If more than one
|
||||
;; initarg in initargs can set the slot, the leftmost one should set it. 2) Any slot not set
|
||||
;; by step 1, may be set from its initform by step 2. Only those slots specified by the
|
||||
;; slot-names argument are set. If slot-names is: T any slot not set in step 1 is set from
|
||||
;; its initform <list of slot names> any slot in the list, and not set in step 1 is set from
|
||||
;; its initform () no slots are set from initforms
|
||||
(let* ((class (class-of instance))
|
||||
(slotds (class-slots class)))
|
||||
(dolist (slotd slotds)
|
||||
(let ((slot-name (slotd-name slotd))
|
||||
(slot-initargs (slotd-initargs slotd)))
|
||||
(flet ((from-initargs nil
|
||||
|
||||
;; Try to initialize the slot from one of the initargs. If we
|
||||
;; succeed return T, otherwise return nil.
|
||||
(doplist (initarg val)
|
||||
initargs
|
||||
(when (memq initarg slot-initargs)
|
||||
(setf (slot-value instance slot-name)
|
||||
val)
|
||||
(return 't))))
|
||||
(from-initforms nil
|
||||
|
||||
;; Try to initialize the slot from its initform. This returns
|
||||
;; no meaningful value.
|
||||
(if (and slot-names (or (eq slot-names 't)
|
||||
(memq slot-name slot-names))
|
||||
(not (slot-boundp instance slot-name)))
|
||||
(let ((initfunction (slotd-initfunction slotd)))
|
||||
(when initfunction
|
||||
(setf (slot-value instance slot-name)
|
||||
(funcall initfunction)))))))
|
||||
(or (from-initargs)
|
||||
(from-initforms))))))
|
||||
instance)
|
||||
|
||||
|
||||
;;; if initargs are valid return nil, otherwise signal an error
|
||||
|
||||
|
||||
(defun check-initargs-1 (class initargs methods)
|
||||
(let ((legal (apply #'append (mapcar #'slotd-initargs (class-slots class)))))
|
||||
(unless (getf initargs :allow-other-keys)
|
||||
|
||||
;; Add to the set of slot-filling initargs the set of initargs that are accepted by
|
||||
;; the methods. If at any point we come across &allow-other-keys, we can just quit.
|
||||
(dolist (method methods)
|
||||
(multiple-value-bind (keys allow-other-keys)
|
||||
(function-keywords method)
|
||||
(when allow-other-keys (return-from check-initargs-1 nil))
|
||||
(setq legal (append keys legal))))
|
||||
|
||||
;; Now check the supplied-initarg-names and the default initargs against the total
|
||||
;; set that we know are legal.
|
||||
(doplist (key val)
|
||||
initargs
|
||||
(unless (memq key legal)
|
||||
(error "Invalid initialization argument ~S for class ~S" key (class-name
|
||||
class)))))))
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,364 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
;;; This file defines CLOS's interface to the LAP mechanism. The file is divided into two parts. The
|
||||
;;; first part defines the interface used by CLOS to create abstract LAP code vectors. CLOS never
|
||||
;;; creates lists that represent LAP code directly, it always calls this mechanism to do so. This
|
||||
;;; provides a layer of error checking on the LAP code before it gets to the implementation-specific
|
||||
;;; assembler. Note that this error checking is syntactic only, but even so is useful to have.
|
||||
;;; Because of it, no specific LAP assembler should worry itself with checking the syntax of the LAP
|
||||
;;; code. The second part of the file defines the LAP assemblers for each CLOS port. These are
|
||||
;;; included together in the same file to make it easier to change them all should some random
|
||||
;;; change be made in the LAP mechanism.
|
||||
|
||||
|
||||
(defvar *make-lap-closure-generator*)
|
||||
|
||||
(defvar *precompile-lap-closure-generator*)
|
||||
|
||||
(defvar *lap-in-lisp*)
|
||||
|
||||
(defun make-lap-closure-generator (closure-variables arguments iregs vregs tregs lap-code)
|
||||
(funcall *make-lap-closure-generator* closure-variables arguments iregs vregs tregs lap-code))
|
||||
|
||||
(defmacro precompile-lap-closure-generator (cvars args i-regs v-regs t-regs lap)
|
||||
(funcall *precompile-lap-closure-generator* cvars args i-regs v-regs t-regs lap))
|
||||
|
||||
(defmacro lap-in-lisp (cvars args iregs vregs tregs lap)
|
||||
(declare (ignore cvars args))
|
||||
`(locally (declare (optimize (safety 0)
|
||||
(speed 3)))
|
||||
,(make-lap-prog iregs vregs tregs (flatten-lap lap (opcode :label 'exit-lap-in-lisp)))
|
||||
))
|
||||
|
||||
|
||||
;;; The following functions and macros are used by CLOS when generating LAP code: GENERATING-LAP
|
||||
;;; WITH-LAP-REGISTERS ALLOCATE-REGISTER DEALLOCATE-REGISTER LAP-FLATTEN OPCODE OPERAND
|
||||
|
||||
|
||||
(proclaim '(special *generating-lap*))
|
||||
|
||||
; CAR - alist of free registers CADR
|
||||
; - alist of allocated registers CADDR
|
||||
; - max reg number allocated in each
|
||||
; alist, the entries have the form:
|
||||
; (type . (:REG <n>))
|
||||
|
||||
|
||||
|
||||
;;; This goes around the generation of any lap code. <body> should return a lap code sequence, this
|
||||
;;; macro will take care of converting that to a lap closure generator.
|
||||
|
||||
|
||||
(defmacro generating-lap (closure-variables arguments &body body)
|
||||
`(let* ((*generating-lap* (list nil nil -1)))
|
||||
(finalize-lap-generation nil ,closure-variables ,arguments (progn ,@body))))
|
||||
|
||||
(defmacro generating-lap-in-lisp (closure-variables arguments &body body)
|
||||
`(let* ((*generating-lap* (list nil nil -1)))
|
||||
(finalize-lap-generation t ,closure-variables ,arguments (progn ,@body))))
|
||||
|
||||
|
||||
;;; Each register specification looks like: (<var> <type> &key :reuse <other-reg>)
|
||||
|
||||
|
||||
(defmacro with-lap-registers (register-specifications &body body)
|
||||
|
||||
;; Given that, for now, there is only one keyword argument and that, for now, we do no error
|
||||
;; checking, we can be pretty sleazy about how this works.
|
||||
(flet ((make-allocations
|
||||
nil
|
||||
(gathering1 (collecting)
|
||||
(dolist (spec register-specifications)
|
||||
(gather1 `(,(car spec)
|
||||
(or ,(cadddr spec)
|
||||
(allocate-register ',(cadr spec))))))))
|
||||
(make-deallocations nil (gathering1
|
||||
(collecting)
|
||||
(dolist (spec register-specifications)
|
||||
(gather1 `(unless ,(cadddr spec)
|
||||
(deallocate-register ,(car spec))))))))
|
||||
`(let ,(make-allocations)
|
||||
(multiple-value-prog1 (progn ,@body)
|
||||
,@(make-deallocations)))))
|
||||
|
||||
(defun allocate-register (type)
|
||||
(destructuring-bind (free allocated)
|
||||
*generating-lap*
|
||||
(let ((entry (assoc type free)))
|
||||
(cond (entry (setf (car *generating-lap*)
|
||||
(delete entry free)
|
||||
(cadr *generating-lap*)
|
||||
(cons entry allocated))
|
||||
(cdr entry))
|
||||
(t (let ((new `(,type :reg ,(incf (caddr *generating-lap*)))))
|
||||
(setf (cadr *generating-lap*)
|
||||
(cons new allocated))
|
||||
(cdr new)))))))
|
||||
|
||||
(defun deallocate-register (reg)
|
||||
(let ((entry (rassoc reg (cadr *generating-lap*))))
|
||||
(unless entry (error "Attempt to free an unallocated register."))
|
||||
(push entry (car *generating-lap*))
|
||||
(setf (cadr *generating-lap*)
|
||||
(delete entry (cadr *generating-lap*)))))
|
||||
|
||||
(defvar *precompiling-lap* nil)
|
||||
|
||||
(defun finalize-lap-generation (in-lisp-p closure-variables arguments lap-code)
|
||||
(when (cadr *generating-lap*)
|
||||
(error "Registers still allocated when lap being finalized."))
|
||||
(let ((iregs nil)
|
||||
(vregs nil)
|
||||
(tregs nil))
|
||||
(dolist (entry (car *generating-lap*))
|
||||
(ecase (car entry)
|
||||
(index (push (caddr entry)
|
||||
iregs))
|
||||
(vector (push (caddr entry)
|
||||
vregs))
|
||||
((t) (push (caddr entry)
|
||||
tregs))))
|
||||
(cond (in-lisp-p (macroexpand `(lap-in-lisp ,closure-variables ,arguments ,iregs
|
||||
,vregs
|
||||
,tregs
|
||||
,lap-code)))
|
||||
(*precompiling-lap* (values closure-variables arguments iregs vregs tregs lap-code)
|
||||
)
|
||||
(t (make-lap-closure-generator closure-variables arguments iregs vregs tregs
|
||||
lap-code)))))
|
||||
|
||||
(defun flatten-lap (&rest opcodes-or-sequences)
|
||||
(let ((result nil))
|
||||
(dolist (opcode-or-sequence opcodes-or-sequences result)
|
||||
(cond ((null opcode-or-sequence))
|
||||
((not (consp (car opcode-or-sequence)))
|
||||
; its an opcode
|
||||
(setf result (append result (list opcode-or-sequence))))
|
||||
(t (setf result (append result opcode-or-sequence)))))))
|
||||
|
||||
(defmacro flattening-lap nil '(let ((result nil))
|
||||
(values #'(lambda (value)
|
||||
(push value result))
|
||||
#'(lambda nil (apply #'flatten-lap (reverse result))))))
|
||||
|
||||
|
||||
;;; This code deals with the syntax of the individual opcodes and operands. The first two of these
|
||||
;;; variables are documented to all ports. They are lists of the symbols which name the lap opcodes
|
||||
;;; and operands. They can be useful to determine whether a port has implemented all the required
|
||||
;;; opcodes and operands. The third of these variables is for use of the emitter only.
|
||||
|
||||
|
||||
(defvar *lap-operands* nil)
|
||||
|
||||
(defvar *lap-opcodes* nil)
|
||||
|
||||
(defvar *lap-emitters* (make-hash-table :test #'eq :size 30))
|
||||
|
||||
(defun opcode (name &rest args)
|
||||
(let ((emitter (gethash name *lap-emitters*)))
|
||||
(if emitter
|
||||
(apply emitter args)
|
||||
(error "No opcode named ~S." name))))
|
||||
|
||||
(defun operand (name &rest args)
|
||||
(let ((emitter (gethash name *lap-emitters*)))
|
||||
(if emitter
|
||||
(apply emitter args)
|
||||
(error "No operand named ~S." name))))
|
||||
|
||||
(defmacro defopcode (name types)
|
||||
(let ((fn-name (symbol-append "LAP Opcode " name *the-clos-package*))
|
||||
(lambda-list (mapcar #'(lambda (x)
|
||||
(declare (ignore x))
|
||||
(gensym))
|
||||
types)))
|
||||
`(progn (eval-when (load eval)
|
||||
(load-defopcode ',name ',fn-name))
|
||||
(defun ,fn-name ,lambda-list (defopcode-1 ',name ',types ,@lambda-list)))))
|
||||
|
||||
(defmacro defoperand (name types)
|
||||
(let ((fn-name (symbol-append "LAP Operand " name *the-clos-package*))
|
||||
(lambda-list (mapcar #'(lambda (x)
|
||||
(declare (ignore x))
|
||||
(gensym))
|
||||
types)))
|
||||
`(progn (eval-when (load eval)
|
||||
(load-defoperand ',name ',fn-name))
|
||||
(defun ,fn-name ,lambda-list (defoperand-1 ',name ',types ,@lambda-list)))))
|
||||
|
||||
(defun load-defopcode (name fn-name)
|
||||
(if* (memq name *lap-operands*)
|
||||
(error "LAP opcodes and operands must have disjoint names.")
|
||||
(setf (gethash name *lap-emitters*)
|
||||
fn-name)
|
||||
(pushnew name *lap-opcodes*)))
|
||||
|
||||
(defun load-defoperand (name fn-name)
|
||||
(if* (memq name *lap-opcodes*)
|
||||
(error "LAP opcodes and operands must have disjoint names.")
|
||||
(setf (gethash name *lap-emitters*)
|
||||
fn-name)
|
||||
(pushnew name *lap-operands*)))
|
||||
|
||||
(defun defopcode-1 (name operand-types &rest args)
|
||||
(iterate ((arg (list-elements args))
|
||||
(type (list-elements operand-types)))
|
||||
(check-opcode-arg name arg type))
|
||||
(cons name (copy-list args)))
|
||||
|
||||
(defun defoperand-1 (name operand-types &rest args)
|
||||
(iterate ((arg (list-elements args))
|
||||
(type (list-elements operand-types)))
|
||||
(check-operand-arg name arg type))
|
||||
(cons name (copy-list args)))
|
||||
|
||||
(defun check-opcode-arg (name arg type)
|
||||
(labels ((usual (x)
|
||||
(and (consp arg)
|
||||
(eq (car arg)
|
||||
x)))
|
||||
(check (x)
|
||||
(ecase x
|
||||
((:reg :cdr :constant :iref :cvar :arg :lisp :lisp-variable) (usual x))
|
||||
(:label (symbolp arg))
|
||||
(:operand (and (consp arg)
|
||||
(memq (car arg)
|
||||
*lap-operands*))))))
|
||||
(unless (if (consp type)
|
||||
(if (eq (car type)
|
||||
'or)
|
||||
(some #'check (cdr type))
|
||||
(error "What type is this?"))
|
||||
(check type))
|
||||
(error "The argument ~S to the opcode ~A is not of type ~S." arg name type))))
|
||||
|
||||
(defun check-operand-arg (name arg type)
|
||||
(flet ((check (x)
|
||||
(ecase x
|
||||
(:symbol (symbolp arg))
|
||||
(:register-number (and (integerp arg)
|
||||
(>= x 0)))
|
||||
(:t t)
|
||||
(:reg (and (consp arg)
|
||||
(eq (car arg)
|
||||
:reg)))
|
||||
(:fixnum (typep arg 'fixnum)))))
|
||||
(unless (if (consp type)
|
||||
(if (eq (car type)
|
||||
'or)
|
||||
(some #'check (cdr type))
|
||||
(error "What type is this?"))
|
||||
(check type))
|
||||
(error "The argument ~S to the operand ~A is not of type ~S." arg name type))))
|
||||
|
||||
|
||||
;;; The actual opcodes.
|
||||
|
||||
|
||||
(defopcode :break nil)
|
||||
|
||||
; For debugging only. Not
|
||||
|
||||
|
||||
(defopcode :beep nil)
|
||||
|
||||
; all ports are required to
|
||||
|
||||
|
||||
(defopcode :print (:reg))
|
||||
|
||||
; implement this.
|
||||
|
||||
|
||||
(defopcode :move (:operand (or :reg :iref :cdr :lisp-variable)))
|
||||
|
||||
(defopcode :eq ((or :reg :constant)
|
||||
(or :reg :constant)
|
||||
:label))
|
||||
|
||||
(defopcode :neq ((or :reg :constant)
|
||||
(or :reg :constant)
|
||||
:label))
|
||||
|
||||
(defopcode :fix= ((or :reg :constant)
|
||||
(or :reg :constant)
|
||||
:label))
|
||||
|
||||
(defopcode :izerop (:reg :label))
|
||||
|
||||
(defopcode :std-instance-p (:reg :label))
|
||||
|
||||
(defopcode :fsc-instance-p (:reg :label))
|
||||
|
||||
(defopcode :built-in-instance-p (:reg :label))
|
||||
|
||||
(defopcode :structure-instance-p (:reg :label))
|
||||
|
||||
(defopcode :jmp ((or :reg :constant)))
|
||||
|
||||
(defopcode :label (:label))
|
||||
|
||||
(defopcode :go (:label))
|
||||
|
||||
(defopcode :return ((or :reg :constant)))
|
||||
|
||||
(defopcode :exit-lap-in-lisp nil)
|
||||
|
||||
|
||||
;;; The actual operands.
|
||||
|
||||
|
||||
(defoperand :reg (:register-number))
|
||||
|
||||
(defoperand :cvar (:symbol))
|
||||
|
||||
(defoperand :arg (:symbol))
|
||||
|
||||
(defoperand :cdr (:reg))
|
||||
|
||||
(defoperand :constant (:t))
|
||||
|
||||
(defoperand :std-wrapper (:reg))
|
||||
|
||||
(defoperand :fsc-wrapper (:reg))
|
||||
|
||||
(defoperand :built-in-wrapper (:reg))
|
||||
|
||||
(defoperand :structure-wrapper (:reg))
|
||||
|
||||
(defoperand :other-wrapper (:reg))
|
||||
|
||||
(defoperand :std-slots (:reg))
|
||||
|
||||
(defoperand :fsc-slots (:reg))
|
||||
|
||||
(defoperand :cref (:reg :fixnum))
|
||||
|
||||
(defoperand :iref (:reg :reg))
|
||||
|
||||
(defoperand :iset (:reg :reg :reg))
|
||||
|
||||
(defoperand :i1+ (:reg))
|
||||
|
||||
(defoperand :i+ (:reg :reg))
|
||||
|
||||
(defoperand :i- (:reg :reg))
|
||||
|
||||
(defoperand :ilogand (:reg :reg))
|
||||
|
||||
(defoperand :ilogxor (:reg :reg))
|
||||
|
||||
(defoperand :ishift (:reg :fixnum))
|
||||
|
||||
(defoperand :lisp (:t))
|
||||
|
||||
(defoperand :lisp-variable (:symbol))
|
||||
|
||||
|
||||
;;; LAP tests (there need to be a lot more of these)
|
||||
|
||||
@@ -1,42 +0,0 @@
|
||||
;;; -*- Mode: Lisp; Package: xcl-User ; Base: 10.; Syntax: Common-Lisp -*-
|
||||
;;;
|
||||
|
||||
(in-package "CLOS" :use (list (or (find-package :walker)
|
||||
(make-package :walker :use '(:lisp)))
|
||||
(or (find-package :iterate)
|
||||
(make-package :iterate
|
||||
:use '(:lisp :walker)))
|
||||
(find-package :lisp)))
|
||||
(export (intern (symbol-name :iterate) ;Have to do this here,
|
||||
(find-package :iterate)) ;because in the defsystem
|
||||
(find-package :iterate)) ;(later in this file)
|
||||
;we use the symbol iterate
|
||||
;to name the file
|
||||
|
||||
(defun load-truename (&optional (errorp nil))
|
||||
(flet ((bad-time ()
|
||||
(when errorp
|
||||
(error "LOAD-TRUENAME called but a file isn't being loaded."))))
|
||||
(let ((filename (pathname (il:fullname *standard-input*))))
|
||||
(if filename
|
||||
(make-pathname :host (pathname-host filename) :device
|
||||
(pathname-device filename) :directory
|
||||
(pathname-directory filename) :name "")
|
||||
(bad-time)))))
|
||||
|
||||
(defvar *clos-directory* (load-truename))
|
||||
|
||||
(defun load-clos (&optional pathname)
|
||||
(defvar *clos-system-date* "7/14/91 Medley 2.0 (interim)")
|
||||
(defvar *the-clos-package* (find-package :clos))
|
||||
(dolist (filename '(patch pkg walk iterate macros low low2 fin
|
||||
defclass defs fngen lap plap cache dlap boot
|
||||
vector slots init std-class cpl braid fsc methods
|
||||
combin dfun precom1 precom2 precom4 fixup
|
||||
defcombin ctypes construct env))
|
||||
|
||||
(load (merge-pathnames
|
||||
(make-pathname :name (string-downcase filename) :type
|
||||
"dfasl") (or pathname *clos-directory*))))
|
||||
(pushnew :clos cl:*features*))
|
||||
|
||||
@@ -1,194 +0,0 @@
|
||||
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
|
||||
;;; File converted on 26-Mar-91 10:29:45 from source low
|
||||
;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>low.;4 created 27-Feb-91 17:16:47
|
||||
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
|
||||
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
;;; Shadow, Export, Require, Use-package, and Import forms should follow here
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
;;;*************************************************************************
|
||||
;;;Copyright (c) 1991 Venue
|
||||
;;; This file contains portable versions of low-level functions and macros which are ripe for
|
||||
;;; implementation specific customization. None of the code in this file *has* to be customized for
|
||||
;;; a particular Common Lisp implementation. Moreover, in some implementations it may not make any
|
||||
;;; sense to customize some of this code. ks.
|
||||
|
||||
|
||||
(defmacro %svref (vector index)
|
||||
`(locally (declare (optimize (speed 3)
|
||||
(safety 0))
|
||||
(inline svref))
|
||||
(svref (the simple-vector ,vector)
|
||||
(the fixnum ,index))))
|
||||
|
||||
(defsetf %svref (vector index)
|
||||
(new-value)
|
||||
`(locally (declare (optimize (speed 3)
|
||||
(safety 0))
|
||||
(inline svref))
|
||||
(setf (svref (the simple-vector ,vector)
|
||||
(the fixnum ,index))
|
||||
,new-value)))
|
||||
|
||||
|
||||
;;; without-interrupts OK, Common Lisp doesn't have this and for good reason. But For all of the
|
||||
;;; Common Lisp's that CLOS runs on today, there is a meaningful way to implement this. WHAT I MEAN
|
||||
;;; IS: I want the body to be evaluated in such a way that no other code that is running CLOS can be
|
||||
;;; run during that evaluation. I agree that the body won't take *long* to evaluate. That is to
|
||||
;;; say that I will only use without interrupts around relatively small computations. INTERRUPTS-ON
|
||||
;;; should turn interrupts back on if they were on. INTERRUPTS-OFF should turn interrupts back off.
|
||||
;;; These are only valid inside the body of WITHOUT-INTERRUPTS. OK?
|
||||
|
||||
|
||||
|
||||
;;; AKW: IT'S CALLED, BUT NEVER REALLY USED, SO I'VE REPLACED IT WITH THE PROGN. IF WE REALLY NEED
|
||||
;;; IT, CAN BE TRIVIALLY DONE WITH IL:MONITORS
|
||||
|
||||
|
||||
(defmacro without-interrupts (&body body)
|
||||
`(progn ,.body))
|
||||
|
||||
|
||||
;;; Very Low-Level representation of instances with meta-class standard-class.
|
||||
|
||||
|
||||
(defmacro std-instance-wrapper (x)
|
||||
`(%std-instance-wrapper ,x))
|
||||
|
||||
(defmacro std-instance-slots (x)
|
||||
`(%std-instance-slots ,x))
|
||||
|
||||
(defun print-std-instance (instance stream depth)
|
||||
; A temporary definition used
|
||||
(declare (ignore depth))
|
||||
; for debugging the bootstrap
|
||||
(printing-random-thing (instance stream)
|
||||
; code of CLOS (See high.lisp).
|
||||
(format stream "#<std-instance>")))
|
||||
|
||||
(defmacro %allocate-instance--class (no-of-slots)
|
||||
`(let ((instance (%%allocate-instance--class)))
|
||||
(%allocate-instance--class-1 ,no-of-slots instance)
|
||||
instance))
|
||||
|
||||
(defmacro %allocate-instance--class-1 (no-of-slots instance)
|
||||
(once-only (instance)
|
||||
`(progn (setf (std-instance-slots ,instance)
|
||||
(%allocate-static-slot-storage--class ,no-of-slots)))))
|
||||
|
||||
|
||||
;;; This is the value that we stick into a slot to tell us that it is unbound. It may seem gross,
|
||||
;;; but for performance reasons, we make this an interned symbol. That means that the fast check to
|
||||
;;; see if a slot is unbound is to say (EQ <val> '..SLOT-UNBOUND..). That is considerably faster
|
||||
;;; than looking at the value of a special variable. Be careful, there are places in the code which
|
||||
;;; actually use ..slot-unbound.. rather than this variable. So much for modularity
|
||||
|
||||
|
||||
(defvar *slot-unbound* '..slot-unbound..)
|
||||
|
||||
(defmacro %allocate-static-slot-storage--class (no-of-slots)
|
||||
`(make-array ,no-of-slots :initial-element *slot-unbound*))
|
||||
|
||||
(defmacro std-instance-class (instance)
|
||||
`(wrapper-class (std-instance-wrapper ,instance)))
|
||||
|
||||
|
||||
;;
|
||||
|
||||
|
||||
|
||||
;;; FUNCTION-ARGLIST
|
||||
|
||||
|
||||
|
||||
;;
|
||||
|
||||
|
||||
|
||||
;;; [COMMENTED OUT AKW. NEVER CALLED] Given something which is functionp, function-arglist should
|
||||
;;; return the argument list for it. CLOS does not count on having this available, but
|
||||
;;; MAKE-SPECIALIZABLE works much better if it is available. Versions of function-arglist for each
|
||||
;;; specific port of clos should be put in the appropriate xxx-low file. This is what it should look
|
||||
;;; like:
|
||||
|
||||
|
||||
; (defun function-arglist (function)
|
||||
; (<system-dependent-arglist-function>
|
||||
; function))
|
||||
|
||||
|
||||
|
||||
;; (FUNCTIONS CLOS::FUNCTION-PRETTY-ARGLIST) (SETFS CLOS::FUNCTION-PRETTY-ARGLIST) (FUNCTIONS
|
||||
;; CLOS::SET-FUNCTION-PRETTY-ARGLIST)
|
||||
|
||||
|
||||
|
||||
;;; set-function-name When given a function should give this function the name <new-name>. Note that
|
||||
;;; <new-name> is sometimes a list. Some lisps get the upset in the tummy when they start thinking
|
||||
;;; about functions which have lists as names. To deal with that there is set-function-name-intern
|
||||
;;; which takes a list spec for a function name and turns it into a symbol if need be. When given a
|
||||
;;; funcallable instance, set-function-name MUST side-effect that FIN to give it the name. When
|
||||
;;; given any other kind of function set-function-name is allowed to return new function which is
|
||||
;;; the 'same' except that it has the name. In all cases, set-function-name must return the new (or
|
||||
;;; same) function.
|
||||
|
||||
|
||||
(defun set-function-name #'new-name (declare (notinline set-function-name-1 intern-function-name))
|
||||
(set-function-name-1 function (intern-function-name new-name)
|
||||
new-name))
|
||||
|
||||
(defun set-function-name-1 (fn new-name uninterned-name)
|
||||
(cond ((typep fn 'il:compiled-closure)
|
||||
(il:\\rplptr (compiled-closure-fnheader fn)
|
||||
4 new-name)
|
||||
(when (and (consp uninterned-name)
|
||||
(eq (car uninterned-name)
|
||||
'method))
|
||||
(let ((debug (si::compiled-function-debugging-info fn)))
|
||||
(when debug
|
||||
(setf (cdr debug)
|
||||
uninterned-name)))))
|
||||
(t nil))
|
||||
fn)
|
||||
|
||||
(defun intern-function-name (name)
|
||||
(cond ((symbolp name)
|
||||
name)
|
||||
((listp name)
|
||||
(intern (let ((*package* *the-clos-package*)
|
||||
(*print-case* :upcase)
|
||||
(*print-gensym* 't))
|
||||
(format nil "~S" name))
|
||||
*the-clos-package*))))
|
||||
|
||||
|
||||
;;; COMPILE-LAMBDA This is like the Common Lisp function COMPILE. In fact, that is what it ends up
|
||||
;;; calling.
|
||||
|
||||
|
||||
(defun compile-lambda (lambda &rest desirability)
|
||||
(declare (ignore desirability))
|
||||
(compile nil lambda))
|
||||
|
||||
(defmacro precompile-random-code-segments (&optional system)
|
||||
`(progn
|
||||
(precompile-function-generators ,system)
|
||||
(precompile-dfun-constructors ,system)))
|
||||
|
||||
|
||||
|
||||
(defun record-definition (type spec &rest args)
|
||||
(declare (ignore type spec args))
|
||||
())
|
||||
|
||||
(defun doctor-dfun-for-the-debugger (gf dfun) (declare (ignore gf)) dfun)
|
||||
@@ -1,144 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
|
||||
;;; File converted on 26-Mar-91 10:30:44 from source xerox-low
|
||||
;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>xerox-low.;3 created 27-Feb-91 16:37:43
|
||||
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
|
||||
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
;;; Shadow, Export, Require, Use-package, and Import forms should follow here
|
||||
|
||||
|
||||
|
||||
;;; ************************************************************************* This is the 1100
|
||||
;;; (Xerox version) of the file portable-low.
|
||||
|
||||
|
||||
(defmacro load-time-eval (form)
|
||||
`(il:loadtimeconstant ,form))
|
||||
|
||||
|
||||
;;; make the pointer from an instance to its class wrapper be an xpointer. this prevents instance
|
||||
;;; creation from spending a lot of time incrementing the large refcount of the class-wrapper. This
|
||||
;;; is safe because there will always be some other pointer to the wrapper to keep it around.
|
||||
|
||||
|
||||
(defstruct (std-instance (:predicate std-instance-p)
|
||||
(:conc-name %std-instance-)
|
||||
(:constructor %%allocate-instance--class nil)
|
||||
(:fast-accessors t)
|
||||
(:print-function %print-std-instance))
|
||||
(wrapper nil :type il:fullxpointer)
|
||||
(slots nil))
|
||||
|
||||
(defun %print-std-instance (instance &optional stream depth)
|
||||
|
||||
;; See the IRM, section 25.3.3. Unfortunatly, that documentation is not correct. In
|
||||
;; particular, it makes no mention of the third argument.
|
||||
(cond ((streamp stream)
|
||||
|
||||
;; Use the standard CLOS printing method, then return T to tell the printer that we
|
||||
;; have done the printing ourselves.
|
||||
(print-std-instance instance stream depth)
|
||||
t)
|
||||
(t
|
||||
;; Internal printing (again, see the IRM section 25.3.3). Return a list containing
|
||||
;; the string of characters that would be printed, if the object were being printed
|
||||
;; for real.
|
||||
(list (with-output-to-string (stream)
|
||||
(print-std-instance instance stream depth))))))
|
||||
|
||||
|
||||
;;
|
||||
|
||||
|
||||
|
||||
;;; FUNCTION-ARGLIST
|
||||
|
||||
|
||||
|
||||
;;
|
||||
|
||||
|
||||
(defun function-arglist (x)
|
||||
|
||||
;; Xerox lisp has the bad habit of returning a symbol to mean &rest, and strings instead of
|
||||
;; symbols. How silly.
|
||||
(let ((arglist (il:arglist x)))
|
||||
(when (symbolp arglist)
|
||||
|
||||
;; This could be due to trying to extract the arglist of an interpreted function
|
||||
;; (though why that should be hard is beyond me). On the other hand, if the
|
||||
;; function is compiled, it helps to ask for the "smart" arglist.
|
||||
(setq arglist (if (consp (symbol-function x))
|
||||
(second (symbol-function x))
|
||||
(il:arglist x t))))
|
||||
(if (symbolp arglist)
|
||||
|
||||
;; Probably never get here, but just in case
|
||||
(list '&rest 'rest)
|
||||
|
||||
;; Make sure there are no strings where there should be symbols
|
||||
(if (some #'stringp arglist)
|
||||
(mapcar #'(lambda (a)
|
||||
(if (symbolp a)
|
||||
a
|
||||
(intern a)))
|
||||
arglist)
|
||||
arglist))))
|
||||
|
||||
(defun printing-random-thing-internal (thing stream)
|
||||
(let ((*print-base* 8))
|
||||
(princ (il:\\hiloc thing)
|
||||
stream)
|
||||
(princ "," stream)
|
||||
(princ (il:\\loloc thing)
|
||||
stream)))
|
||||
|
||||
(defun record-definition (name type &optional parent-name parent-type)
|
||||
(declare (ignore type parent-name))
|
||||
nil)
|
||||
|
||||
|
||||
;;; FIN uses this too!
|
||||
|
||||
|
||||
(eval-when (compile load eval)
|
||||
(il:datatype il:compiled-closure (il:fnheader il:environment))
|
||||
(il:blockrecord closure-overlay ((funcallable-instance-p il:flag))))
|
||||
|
||||
(defun compiled-closure-fnheader (compiled-closure)
|
||||
(il:fetch (il:compiled-closure il:fnheader)
|
||||
il:of compiled-closure))
|
||||
|
||||
(defun set-compiled-closure-fnheader (compiled-closure nv)
|
||||
(il:replace (il:compiled-closure il:fnheader)
|
||||
il:of compiled-closure nv))
|
||||
|
||||
(defsetf compiled-closure-fnheader set-compiled-closure-fnheader)
|
||||
|
||||
|
||||
;;; In Lyric, and until the format of FNHEADER changes, getting the name from a compiled closure
|
||||
;;; looks like this: (fetchfield '(nil 4 pointer) (fetch (compiled-closure fnheader) closure)) Of
|
||||
;;; course this is completely non-robust, but it will work for now. This is not the place to go
|
||||
;;; into a long tyrade about what is wrong with having record package definitions go away when you
|
||||
;;; ship the sysout; there isn't enough diskspace.
|
||||
|
||||
|
||||
(defun set-function-name-1 (fn new-name uninterned-name)
|
||||
(cond ((typep fn 'il:compiled-closure)
|
||||
(il:\\rplptr (compiled-closure-fnheader fn)
|
||||
4 new-name)
|
||||
(when (and (consp uninterned-name)
|
||||
(eq (car uninterned-name)
|
||||
'method))
|
||||
(let ((debug (si::compiled-function-debugging-info fn)))
|
||||
(when debug
|
||||
(setf (cdr debug)
|
||||
uninterned-name)))))
|
||||
(t nil))
|
||||
fn)
|
||||
@@ -1,355 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
|
||||
;;; File converted on 26-Mar-91 10:27:21 from source macros
|
||||
;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>macros.;3 created 19-Feb-91 13:51:21
|
||||
|
||||
;;;. Copyright (c) 1991 Venue
|
||||
|
||||
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
|
||||
;;;Macros global variable
|
||||
;;; definitions, and other random support stuff used by the rest of the system. For simplicity (not
|
||||
;;; having to use eval-when a lot), this file must be loaded before it can be compiled.
|
||||
|
||||
|
||||
(in-package 'clos)
|
||||
|
||||
(proclaim '(declaration values arglist indentation class variable-rebinding clos-fast-call))
|
||||
|
||||
|
||||
;;; Age old functions which CommonLisp cleaned-up away. They probably exist in other packages in
|
||||
;;; all CommonLisp implementations, but I will leave it to the compiler to optimize into calls to
|
||||
;;; them. Common Lisp BUG: Some Common Lisps define these in the Lisp package which causes all sorts
|
||||
;;; of lossage. Common Lisp should explictly specify which symbols appear in the Lisp package.
|
||||
|
||||
|
||||
(eval-when (compile load eval)
|
||||
(defmacro memq (item list)
|
||||
`(member ,item ,list :test #'eq))
|
||||
(defmacro assq (item list)
|
||||
`(assoc ,item ,list :test #'eq))
|
||||
(defmacro rassq (item list)
|
||||
`(rassoc ,item ,list :test #'eq))
|
||||
(defmacro delq (item list)
|
||||
`(delete ,item ,list :test #'eq))
|
||||
(defmacro posq (item list)
|
||||
`(position ,item ,list :test #'eq))
|
||||
(defmacro neq (x y)
|
||||
`(not (eq ,x ,y)))
|
||||
(defun make-caxr (n form)
|
||||
(if (< n 4)
|
||||
`(,(nth n '(car cadr caddr cadddr))
|
||||
,form)
|
||||
(make-caxr (- n 4)
|
||||
`(cddddr ,form))))
|
||||
(defun make-cdxr (n form)
|
||||
(cond ((zerop n)
|
||||
form)
|
||||
((< n 5)
|
||||
`(,(nth n '(identity cdr cddr cdddr cddddr))
|
||||
,form))
|
||||
(t (make-cdxr (- n 4)
|
||||
`(cddddr ,form))))))
|
||||
|
||||
(defun zero (&rest ignore)
|
||||
(declare (ignore ignore))
|
||||
0)
|
||||
|
||||
(defun make-plist (keys vals)
|
||||
(if (null vals)
|
||||
nil
|
||||
(list* (car keys)
|
||||
(car vals)
|
||||
(make-plist (cdr keys)
|
||||
(cdr vals)))))
|
||||
|
||||
(defun remtail (list tail)
|
||||
(if (eq list tail)
|
||||
nil
|
||||
(cons (car list)
|
||||
(remtail (cdr list)
|
||||
tail))))
|
||||
|
||||
|
||||
;;; ONCE-ONLY does the same thing as it does in zetalisp. I should have just lifted it from there
|
||||
;;; but I am honest. Not only that but this one is written in Common Lisp. I feel a lot like
|
||||
;;; bootstrapping, or maybe more like rebuilding Rome.
|
||||
|
||||
|
||||
(defmacro once-only (vars &body body)
|
||||
(let ((gensym-var (gensym))
|
||||
(run-time-vars (gensym))
|
||||
(run-time-vals (gensym))
|
||||
(expand-time-val-forms nil))
|
||||
(dolist (var vars)
|
||||
(push `(if (or (symbolp ,var)
|
||||
(numberp ,var)
|
||||
(and (listp ,var)
|
||||
(member (car ,var)
|
||||
''function)))
|
||||
,var
|
||||
(let ((,gensym-var (gensym)))
|
||||
(push ,gensym-var ,run-time-vars)
|
||||
(push ,var ,run-time-vals)
|
||||
,gensym-var))
|
||||
expand-time-val-forms))
|
||||
`(let* (,run-time-vars ,run-time-vals (wrapped-body (let ,(mapcar #'list vars
|
||||
(reverse
|
||||
expand-time-val-forms
|
||||
))
|
||||
,@body)))
|
||||
`(let ,(mapcar #'list (reverse ,run-time-vars)
|
||||
(reverse ,run-time-vals))
|
||||
,wrapped-body))))
|
||||
|
||||
(eval-when
|
||||
(compile load eval)
|
||||
(defun extract-declarations (body &optional environment)
|
||||
(declare (values documentation declarations body))
|
||||
(let (documentation declarations form)
|
||||
(when (and (stringp (car body))
|
||||
(cdr body))
|
||||
(setq documentation (pop body)))
|
||||
(block outer
|
||||
(loop (when (null body)
|
||||
(return-from outer nil))
|
||||
(setq form (car body))
|
||||
(when (block inner
|
||||
(loop (cond ((not (listp form))
|
||||
(return-from outer nil))
|
||||
((eq (car form)
|
||||
'declare)
|
||||
(return-from inner 't))
|
||||
(t (multiple-value-bind
|
||||
(newform macrop)
|
||||
(macroexpand-1 form environment)
|
||||
(if (or (not (eq newform form))
|
||||
macrop)
|
||||
(setq form newform)
|
||||
(return-from outer nil)))))))
|
||||
(pop body)
|
||||
(dolist (declaration (cdr form))
|
||||
(push declaration declarations)))))
|
||||
(values documentation (and declarations `((declare ,.(nreverse declarations))))
|
||||
body))))
|
||||
|
||||
(defvar *keyword-package* (find-package 'keyword))
|
||||
|
||||
(defun make-keyword (symbol)
|
||||
(intern (symbol-name symbol)
|
||||
*keyword-package*))
|
||||
|
||||
(eval-when (compile load eval)
|
||||
(defun string-append (&rest strings)
|
||||
(setq strings (copy-list strings))
|
||||
; The explorer can't even rplaca an
|
||||
; &rest arg?
|
||||
(do ((string-loc strings (cdr string-loc)))
|
||||
((null string-loc)
|
||||
(apply #'concatenate 'string strings))
|
||||
(rplaca string-loc (string (car string-loc))))))
|
||||
|
||||
(defun symbol-append (sym1 sym2 &optional (package *package*))
|
||||
(intern (string-append sym1 sym2)
|
||||
package))
|
||||
|
||||
(defmacro check-member (place list &key (test #'eql)
|
||||
(pretty-name place))
|
||||
(once-only (place list)
|
||||
`(or (member ,place ,list :test ,test)
|
||||
(error "The value of ~A, ~S is not one of ~S." ',pretty-name ,place ,list))))
|
||||
|
||||
(defmacro alist-entry (alist key make-entry-fn)
|
||||
(once-only (alist key)
|
||||
`(or (assq ,key ,alist)
|
||||
(progn (setf ,alist (cons (,make-entry-fn ,key)
|
||||
,alist))
|
||||
(car ,alist)))))
|
||||
|
||||
(defmacro collecting-once (&key initial-value)
|
||||
`(let* ((head ,initial-value)
|
||||
(tail ,(and initial-value `(last head))))
|
||||
(values #'(lambda (value)
|
||||
(if (null head)
|
||||
(setq head (setq tail (list value)))
|
||||
(unless (memq value head)
|
||||
(setq tail (cdr (rplacd tail (list value)))))))
|
||||
#'(lambda nil head))))
|
||||
|
||||
(defmacro doplist ((key val)
|
||||
plist &body body &environment env)
|
||||
(multiple-value-bind (doc decls bod)
|
||||
(extract-declarations body env)
|
||||
(declare (ignore doc))
|
||||
`(let ((.plist-tail. ,plist)
|
||||
,key
|
||||
,val)
|
||||
,@decls
|
||||
(loop (when (null .plist-tail.)
|
||||
(return nil))
|
||||
(setq ,key (pop .plist-tail.))
|
||||
(when (null .plist-tail.)
|
||||
(error "Malformed plist in doplist, odd number of elements."))
|
||||
(setq ,val (pop .plist-tail.))
|
||||
(progn ,@bod)))))
|
||||
|
||||
(defmacro if* (condition true &rest false)
|
||||
`(if ,condition
|
||||
,true
|
||||
(progn ,@false)))
|
||||
|
||||
|
||||
;;
|
||||
|
||||
|
||||
|
||||
;;; printing-random-thing
|
||||
|
||||
|
||||
|
||||
;;
|
||||
|
||||
|
||||
|
||||
;;; Similar to printing-random-object in the lisp machine but much simpler and machine independent.
|
||||
|
||||
|
||||
(defmacro printing-random-thing ((thing stream)
|
||||
&body body)
|
||||
(once-only (stream)
|
||||
`(progn (format ,stream "#<")
|
||||
,@body
|
||||
(format ,stream " ")
|
||||
(printing-random-thing-internal ,thing ,stream)
|
||||
(format ,stream ">"))))
|
||||
|
||||
(defun printing-random-thing-internal (thing stream)
|
||||
(let ((*print-base* 8))
|
||||
(princ (il:\\hiloc thing)
|
||||
stream)
|
||||
(princ "," stream)
|
||||
(princ (il:\\loloc thing)
|
||||
stream)))
|
||||
|
||||
|
||||
;;
|
||||
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
|
||||
;;
|
||||
|
||||
|
||||
(defun capitalize-words (string &optional (dashes-p t))
|
||||
(let ((string (copy-seq (string string))))
|
||||
(declare (string string))
|
||||
(do* ((flag t flag)
|
||||
(length (length string)
|
||||
length)
|
||||
(char nil char)
|
||||
(i 0 (+ i 1)))
|
||||
((= i length)
|
||||
string)
|
||||
(setq char (elt string i))
|
||||
(cond ((both-case-p char)
|
||||
(if flag
|
||||
(and (setq flag (lower-case-p char))
|
||||
(setf (elt string i)
|
||||
(char-upcase char)))
|
||||
(and (not flag)
|
||||
(setf (elt string i)
|
||||
(char-downcase char))))
|
||||
(setq flag nil))
|
||||
((char-equal char #\-)
|
||||
(setq flag t)
|
||||
(unless dashes-p
|
||||
(setf (elt string i)
|
||||
#\Space)))
|
||||
(t (setq flag nil))))))
|
||||
|
||||
|
||||
;;; FIND-CLASS This is documented in the CLOS specification.
|
||||
|
||||
|
||||
(defvar *find-class* (make-hash-table :test #'eq))
|
||||
|
||||
(defun legal-class-name-p (x)
|
||||
(and (symbolp x)
|
||||
(not (keywordp x))))
|
||||
|
||||
(defun find-class (symbol &optional (errorp t)
|
||||
environment)
|
||||
(declare (ignore environment))
|
||||
(or (gethash symbol *find-class*)
|
||||
(cond ((null errorp)
|
||||
nil)
|
||||
((legal-class-name-p symbol)
|
||||
(error "No class named: ~S." symbol))
|
||||
(t (error "~S is not a legal class name." symbol)))))
|
||||
|
||||
(defsetf find-class (symbol &optional (errorp t)
|
||||
environment)
|
||||
(new-value)
|
||||
(declare (ignore errorp environment))
|
||||
`(|SETF CLOS FIND-CLASS| ,new-value ,symbol))
|
||||
|
||||
(defun |SETF CLOS FIND-CLASS| (new-value symbol)
|
||||
(if (legal-class-name-p symbol)
|
||||
(setf (gethash symbol *find-class*)
|
||||
new-value)
|
||||
(error "~S is not a legal class name." symbol)))
|
||||
|
||||
(defun find-wrapper (symbol)
|
||||
(class-wrapper (find-class symbol)))
|
||||
|
||||
(defmacro gathering1 (gatherer &body body)
|
||||
`(gathering ((.gathering1. ,gatherer))
|
||||
(macrolet ((gather1 (x)
|
||||
`(gather ,x .gathering1.)))
|
||||
,@body)))
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
(defmacro vectorizing (&key (size 0))
|
||||
`(let* ((limit ,size)
|
||||
(result (make-array limit))
|
||||
(index 0))
|
||||
(values #'(lambda (value)
|
||||
(if (= index limit)
|
||||
(error "vectorizing more elements than promised.")
|
||||
(progn (setf (svref result index)
|
||||
value)
|
||||
(incf index)
|
||||
value)))
|
||||
#'(lambda nil result))))
|
||||
|
||||
|
||||
;;; These are augmented definitions of list-elements and list-tails from iterate.lisp. These
|
||||
;;; versions provide the extra :by keyword which can be used to specify the step function through
|
||||
;;; the list.
|
||||
|
||||
|
||||
(defmacro *list-elements (list &key (by #'cdr))
|
||||
`(let ((tail ,list))
|
||||
#'(lambda (finish)
|
||||
(if (endp tail)
|
||||
(funcall finish)
|
||||
(prog1 (car tail)
|
||||
(setq tail (funcall ,by tail)))))))
|
||||
|
||||
(defmacro *list-tails (list &key (by #'cdr))
|
||||
`(let ((tail ,list))
|
||||
#'(lambda (finish)
|
||||
(prog1 (if (endp tail)
|
||||
(funcall finish)
|
||||
tail)
|
||||
(setq tail (funcall ,by tail))))))
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,143 +0,0 @@
|
||||
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (CL IN-PACKAGE "XCL-USER") BASE 10)
|
||||
(IL:FILECREATED "19-Feb-91 14:09:19"
|
||||
IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>XEROX-PATCHES.;2| 9876
|
||||
|
||||
IL:|changes| IL:|to:| (IL:VARS IL:XEROX-PATCHESCOMS)
|
||||
|
||||
IL:|previous| IL:|date:| " 6-Feb-91 10:55:16"
|
||||
IL:|{DSK}<usr>local>users>welch>lisp>clos>rev4>il-format>XEROX-PATCHES.;1|)
|
||||
|
||||
|
||||
; Copyright (c) 1991 by Venue. All rights reserved.
|
||||
|
||||
(IL:PRETTYCOMPRINT IL:XEROX-PATCHESCOMS)
|
||||
|
||||
(IL:RPAQQ IL:XEROX-PATCHESCOMS (
|
||||
|
||||
|
||||
(IL:FUNCTIONS OPTIMIZE-LOGICAL-OP-1-ARG)
|
||||
(OPTIMIZERS (LOGIOR :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)
|
||||
(LOGXOR :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)
|
||||
(LOGAND :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG)
|
||||
(LOGEQV :OPTIMIZED-BY OPTIMIZE-LOGICAL-OP-1-ARG))
|
||||
|
||||
(IL:* IL:|;;| "A bug compiling LABELS")
|
||||
|
||||
(IL:FUNCTIONS COMPILER::META-CALL-LABELS)
|
||||
(FILE-ENVIRONMENTS "XEROX-PATCHES")))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;;|
|
||||
"Declare side-effects (actually, lack of side-effects) info for some internal arithmetic functions. These are needed because the compiler runs the optimizers before checking the side-effects, so side-effect declarations on the \"real\" functions are oft times ignored. Fix a nit in the compiler While no person would generate code like (logor x), macro can (and do). "
|
||||
)
|
||||
|
||||
|
||||
(DEFUN OPTIMIZE-LOGICAL-OP-1-ARG (FORM ENV CTXT)
|
||||
(DECLARE (IGNORE ENV CTXT))
|
||||
(IF (= 2 (LENGTH FORM))
|
||||
(SECOND FORM)
|
||||
'COMPILER:PASS))
|
||||
|
||||
(DEFOPTIMIZER LOGIOR OPTIMIZE-LOGICAL-OP-1-ARG)
|
||||
|
||||
(DEFOPTIMIZER LOGXOR OPTIMIZE-LOGICAL-OP-1-ARG)
|
||||
|
||||
(DEFOPTIMIZER LOGAND OPTIMIZE-LOGICAL-OP-1-ARG)
|
||||
|
||||
(DEFOPTIMIZER LOGEQV OPTIMIZE-LOGICAL-OP-1-ARG)
|
||||
|
||||
|
||||
|
||||
(IL:* IL:|;;| "A bug compiling LABELS")
|
||||
|
||||
|
||||
(DEFUN COMPILER::META-CALL-LABELS (COMPILER::NODE COMPILER:CONTEXT)
|
||||
|
||||
(IL:* IL:|;;| "This is similar to META-CALL-LAMBDA, but we have some extra information. There are only required arguments, and we have the correct number of them. ")
|
||||
|
||||
(LET ((COMPILER::*MADE-CHANGES* NIL))
|
||||
|
||||
(IL:* IL:|;;| "First, substitute the functions wherever possible.")
|
||||
|
||||
(DOLIST (COMPILER::FN-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE)
|
||||
(WHEN (NULL (COMPILER::NODE-META-P (COMPILER::LABELS-BODY COMPILER::NODE)))
|
||||
(SETF (COMPILER::NODE-META-P COMPILER::NODE)
|
||||
NIL)
|
||||
(SETQ COMPILER::*MADE-CHANGES* T)))
|
||||
(WHEN (COMPILER::SUBSTITUTABLE-P (CDR COMPILER::FN-PAIR)
|
||||
(CAR COMPILER::FN-PAIR))
|
||||
(LET ((COMPILER::*SUBST-OCCURRED* NIL))
|
||||
|
||||
(IL:* IL:|;;| "First try substituting into the body.")
|
||||
|
||||
(SETF (COMPILER::LABELS-BODY COMPILER::NODE)
|
||||
(COMPILER::META-SUBSTITUTE (CDR COMPILER::FN-PAIR)
|
||||
(CAR COMPILER::FN-PAIR)
|
||||
(COMPILER::LABELS-BODY COMPILER::NODE)))
|
||||
(WHEN (NOT COMPILER::*SUBST-OCCURRED*)
|
||||
|
||||
(IL:* IL:|;;| "Wasn't in the body - try the other functions.")
|
||||
|
||||
(DOLIST (COMPILER::TARGET-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE))
|
||||
(UNLESS (EQ COMPILER::TARGET-PAIR COMPILER::FN-PAIR)
|
||||
(SETF (CDR COMPILER::TARGET-PAIR)
|
||||
(COMPILER::META-SUBSTITUTE (CDR COMPILER::FN-PAIR)
|
||||
(CAR COMPILER::FN-PAIR)
|
||||
(CDR COMPILER::TARGET-PAIR)))
|
||||
(WHEN COMPILER::*SUBST-OCCURRED*
|
||||
(IL:* IL:\;
|
||||
"Found it, we can stop now.")
|
||||
(SETF (COMPILER::NODE-META-P COMPILER::NODE)
|
||||
NIL)
|
||||
(SETQ COMPILER::*MADE-CHANGES* T)
|
||||
(RETURN)))))
|
||||
|
||||
(IL:* IL:|;;| "May need to reanalyze the node, since things might have changed. Note that reanalyzing the parts of the node this way means the the state in the enclosing loop is not lost. ")
|
||||
|
||||
(DOLIST (COMPILER::FNS (COMPILER::LABELS-FUNS COMPILER::NODE))
|
||||
(COMPILER::MEVAL (CDR COMPILER::FNS)
|
||||
:ARGUMENT))
|
||||
(COMPILER::MEVAL (COMPILER::LABELS-BODY COMPILER::NODE)
|
||||
:RETURN))))
|
||||
|
||||
(IL:* IL:|;;| "Now remove any functions that aren't referenced.")
|
||||
|
||||
(DOLIST (COMPILER::FN-PAIR (PROG1 (COMPILER::LABELS-FUNS COMPILER::NODE)
|
||||
(SETF (COMPILER::LABELS-FUNS COMPILER::NODE)
|
||||
NIL)))
|
||||
(COND
|
||||
((NULL (COMPILER::VARIABLE-READ-REFS (CAR COMPILER::FN-PAIR)))
|
||||
(COMPILER::RELEASE-TREE (CDR COMPILER::FN-PAIR))
|
||||
(SETQ COMPILER::*MADE-CHANGES* T))
|
||||
(T (PUSH COMPILER::FN-PAIR (COMPILER::LABELS-FUNS COMPILER::NODE)))))
|
||||
|
||||
(IL:* IL:|;;| "If there aren't any functions left, replace the node with its body.")
|
||||
|
||||
(WHEN (NULL (COMPILER::LABELS-FUNS COMPILER::NODE))
|
||||
(LET ((COMPILER::BODY (COMPILER::LABELS-BODY COMPILER::NODE)))
|
||||
(SETF (COMPILER::LABELS-BODY COMPILER::NODE)
|
||||
NIL)
|
||||
(COMPILER::RELEASE-TREE COMPILER::NODE)
|
||||
(SETQ COMPILER::NODE COMPILER::BODY COMPILER::*MADE-CHANGES* T)))
|
||||
|
||||
(IL:* IL:|;;| "Finally, set the meta-p flag if everythings OK.")
|
||||
|
||||
(IF (NULL COMPILER::*MADE-CHANGES*)
|
||||
(SETF (COMPILER::NODE-META-P COMPILER::NODE)
|
||||
COMPILER:CONTEXT)
|
||||
(SETF (COMPILER::NODE-META-P COMPILER::NODE)
|
||||
NIL)))
|
||||
COMPILER::NODE)
|
||||
|
||||
(DEFINE-FILE-ENVIRONMENT "XEROX-PATCHES" :PACKAGE (IN-PACKAGE "XCL-USER")
|
||||
:READTABLE "XCL"
|
||||
:BASE 10
|
||||
:COMPILER :COMPILE-FILE)
|
||||
(IL:PUTPROPS IL:XEROX-PATCHES IL:COPYRIGHT ("Venue" 1991))
|
||||
(IL:DECLARE\: IL:DONTCOPY
|
||||
(IL:FILEMAP (NIL)))
|
||||
IL:STOP
|
||||
@@ -1,81 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
|
||||
;;; File converted on 26-Mar-91 10:23:29 from source pkg
|
||||
;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>pkg.;4 created 1-Mar-91 10:10:26
|
||||
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
|
||||
|
||||
;;; Some CommonLisps have more symbols in the Lisp package than the ones that are explicitly
|
||||
;;; specified in CLtL. This causes trouble. Any Lisp that has extra symbols in the Lisp package
|
||||
;;; should shadow those symbols in the CLOS package.
|
||||
|
||||
|
||||
(shadow 'cl:documentation)
|
||||
|
||||
|
||||
;;; These come from the index pages of 88-002R.
|
||||
|
||||
(eval-when (compile load eval)
|
||||
(defvar *exports*
|
||||
'(add-method built-in-class call-method call-next-method change-class class-name class-of
|
||||
compute-applicable-methods defclass defgeneric define-method-combination defmethod
|
||||
ensure-generic-function find-class find-method function-keywords generic-flet
|
||||
generic-labels initialize-instance invalid-method-error make-instance
|
||||
make-instances-obsolete method-combination-error method-qualifiers next-method-p
|
||||
no-applicable-method no-next-method print-object reinitialize-instance remove-method
|
||||
shared-initialize slot-boundp slot-exists-p slot-makunbound slot-missing slot-unbound
|
||||
slot-value standard standard-class standard-generic-function standard-method
|
||||
standard-object structure-class symbol-macrolet update-instance-for-different-class
|
||||
update-instance-for-redefined-class with-accessors with-added-methods with-slots))
|
||||
|
||||
(import '(xcl:false xcl:destructuring-bind xcl:true) *the-clos-package*)
|
||||
|
||||
(export *exports* *the-clos-package*)
|
||||
|
||||
(import *exports* (find-package :lisp))
|
||||
|
||||
(export *exports* (find-package :lisp)))
|
||||
|
||||
; (defvar *chapter-3-exports* '(
|
||||
; get-setf-function
|
||||
; get-setf-function-name
|
||||
; class-prototype class object
|
||||
|
||||
|
||||
|
||||
;; essential-class
|
||||
|
||||
|
||||
; class-name class-precedence-list
|
||||
; class-local-supers class-local-slots
|
||||
; class-direct-subclasses
|
||||
; class-direct-methods class-slots
|
||||
; method-arglist
|
||||
; method-argument-specifiers
|
||||
; method-function method-equal
|
||||
; slotd-name slot-missing
|
||||
|
||||
|
||||
|
||||
;; define-meta-class %allocate-instance %instance-ref %instancep %instance-meta-class
|
||||
|
||||
|
||||
; allocate-instance optimize-slot-value
|
||||
; optimize-setf-of-slot-value
|
||||
; add-named-class
|
||||
; class-for-redefinition add-class
|
||||
; supers-changed slots-changed
|
||||
; check-super-metaclass-compatibility
|
||||
; make-slotd
|
||||
; compute-class-precedence-list
|
||||
; walk-method-body
|
||||
; walk-method-body-form
|
||||
; add-named-method remove-named-method
|
||||
; ))
|
||||
|
||||
@@ -1,309 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
|
||||
;;; The portable implementation of the LAP assembler. The portable implementation of the LAP
|
||||
;;; assembler works by translating LAP code back into Lisp code and then compiling that Lisp code.
|
||||
;;; Note that this implementation is actually going to get a lot of use. Some implementations (KCL)
|
||||
;;; won't implement a native LAP assembler at all. Other implementations may not implement native
|
||||
;;; LAP assemblers for all of their ports. All of this implies that this portable LAP assembler
|
||||
;;; needs to generate the best code it possibly can.
|
||||
|
||||
|
||||
(defmacro
|
||||
lap-case
|
||||
(operand &body cases)
|
||||
(once-only
|
||||
(operand)
|
||||
`(ecase (car ,operand)
|
||||
,@(mapcar #'(lambda (case)
|
||||
`(,(car case)
|
||||
(apply #'(lambda ,(cadr case)
|
||||
,@(cddr case))
|
||||
(cdr ,operand))))
|
||||
cases))))
|
||||
|
||||
(defvar *lap-args*)
|
||||
|
||||
(defvar *lap-rest-p*)
|
||||
|
||||
(defvar *lap-i-regs*)
|
||||
|
||||
(defvar *lap-v-regs*)
|
||||
|
||||
(defvar *lap-t-regs*)
|
||||
|
||||
(defvar *lap-optimize-declaration* '((speed 3)
|
||||
(safety 0)
|
||||
(compilation-speed 0)))
|
||||
|
||||
(eval-when (load eval)
|
||||
(setq *make-lap-closure-generator* #'(lambda (closure-var-names arg-names index-regs
|
||||
vector-regs t-regs lap-code)
|
||||
(compile-lambda (make-lap-closure-generator-lambda
|
||||
closure-var-names arg-names
|
||||
index-regs vector-regs t-regs
|
||||
lap-code)))
|
||||
*precompile-lap-closure-generator*
|
||||
#'(lambda (cvars args i-regs v-regs t-regs lap)
|
||||
`#',(make-lap-closure-generator-lambda cvars args i-regs v-regs t-regs lap))
|
||||
*lap-in-lisp*
|
||||
#'(lambda (cvars args iregs vregs tregs lap)
|
||||
(declare (ignore cvars args))
|
||||
(make-lap-prog iregs vregs tregs (flatten-lap lap
|
||||
; (opcode :label 'exit-lap-in-lisp)
|
||||
)))))
|
||||
|
||||
(defun make-lap-closure-generator-lambda (cvars args i-regs v-regs t-regs lap)
|
||||
(let* ((rest (memq '&rest args))
|
||||
(ldiff (and rest (ldiff args rest))))
|
||||
(when rest
|
||||
(setq args (append ldiff '(&rest .lap-rest-arg.))))
|
||||
(let* ((*lap-args* (if rest
|
||||
ldiff
|
||||
args))
|
||||
(*lap-rest-p* (not (null rest))))
|
||||
`(lambda ,cvars #'(lambda ,args (declare (optimize . ,*lap-optimize-declaration*))
|
||||
,(make-lap-prog-internal i-regs v-regs t-regs lap))))))
|
||||
|
||||
(defun make-lap-prog (i-regs v-regs t-regs lap)
|
||||
(let* ((*lap-args* 'lap-in-lisp)
|
||||
(*lap-rest-p* 'lap-in-lisp))
|
||||
(make-lap-prog-internal i-regs v-regs t-regs lap)))
|
||||
|
||||
(defun make-lap-prog-internal (i-regs v-regs t-regs lap)
|
||||
(let* ((*lap-i-regs* i-regs)
|
||||
(*lap-v-regs* v-regs)
|
||||
(*lap-t-regs* t-regs)
|
||||
(code (mapcar #'lap-opcode lap)))
|
||||
`(prog ,(mapcar #'(lambda (reg)
|
||||
`(,(lap-reg reg)
|
||||
,(lap-reg-initial-value-form reg)))
|
||||
(append i-regs v-regs t-regs))
|
||||
(declare (type fixnum ,@(mapcar #'lap-reg *lap-i-regs*))
|
||||
(type simple-vector ,@(mapcar #'lap-reg *lap-v-regs*))
|
||||
(optimize . ,*lap-optimize-declaration*))
|
||||
,.code)))
|
||||
|
||||
(defconstant *empty-vector* '#())
|
||||
|
||||
(defun lap-reg-initial-value-form (reg)
|
||||
(cond ((member reg *lap-i-regs*)
|
||||
0)
|
||||
((member reg *lap-v-regs*)
|
||||
'*empty-vector*)
|
||||
((member reg *lap-t-regs*)
|
||||
nil)
|
||||
(t (error "What kind of register is ~S?" reg))))
|
||||
|
||||
(defun lap-opcode (opcode)
|
||||
(lap-case opcode (:move (from to)
|
||||
`(setf ,(lap-operand to)
|
||||
,(lap-operand from)))
|
||||
((:eq :neq :fix=)
|
||||
(arg1 arg2 label)
|
||||
`(when ,(lap-operands (ecase (car opcode)
|
||||
(:eq 'eq)
|
||||
(:neq 'neq)
|
||||
(:fix= 'runtime\ fix=))
|
||||
arg1 arg2)
|
||||
(go ,label)))
|
||||
((:izerop)
|
||||
(arg label)
|
||||
`(when ,(lap-operands 'runtime\ izerop arg)
|
||||
(go ,label)))
|
||||
(:std-instance-p (from label)
|
||||
`(when ,(lap-operands 'runtime\ std-instance-p from)
|
||||
(go ,label)))
|
||||
(:fsc-instance-p (from label)
|
||||
`(when ,(lap-operands 'runtime\ fsc-instance-p from)
|
||||
(go ,label)))
|
||||
(:built-in-instance-p (from label)
|
||||
(declare (ignore from))
|
||||
`(when ,t
|
||||
(go ,label)))
|
||||
; ***
|
||||
(:structure-instance-p (from label)
|
||||
`(when ,(lap-operands 'runtime\ ??? from)
|
||||
(go ,label)))
|
||||
; ***
|
||||
(:jmp (fn)
|
||||
(if (eq *lap-args* 'lap-in-lisp)
|
||||
(error "Can't do a :JMP in LAP-IN-LISP.")
|
||||
`(return ,(if *lap-rest-p*
|
||||
`(runtime\ apply ,(lap-operand fn)
|
||||
,@*lap-args* .lap-rest-arg.)
|
||||
`(runtime\ funcall ,(lap-operand fn)
|
||||
,@*lap-args*)))))
|
||||
(:return (value)
|
||||
`(return ,(lap-operand value)))
|
||||
(:label (label)
|
||||
label)
|
||||
(:go (label)
|
||||
`(go ,label))
|
||||
(:exit-lap-in-lisp nil `(go exit-lap-in-lisp))
|
||||
(:break nil `(break))
|
||||
(:beep nil)
|
||||
(:print (val)
|
||||
(lap-operands 'print val))))
|
||||
|
||||
(defun lap-operand (operand)
|
||||
(lap-case operand (:reg (n)
|
||||
(lap-reg n))
|
||||
(:cdr (reg)
|
||||
(lap-operands 'cdr reg))
|
||||
((:cvar :arg)
|
||||
(name)
|
||||
name)
|
||||
(:constant (c)
|
||||
`',c)
|
||||
((:std-wrapper :fsc-wrapper :built-in-wrapper :structure-wrapper :std-slots :fsc-slots)
|
||||
(x)
|
||||
(lap-operands (ecase (car operand)
|
||||
(:std-wrapper 'runtime\ std-wrapper)
|
||||
(:fsc-wrapper 'runtime\ fsc-wrapper)
|
||||
(:built-in-wrapper 'runtime\ built-in-wrapper)
|
||||
(:structure-wrapper 'runtime\ structure-wrapper)
|
||||
(:std-slots 'runtime\ std-slots)
|
||||
(:fsc-slots 'runtime\ fsc-slots))
|
||||
x))
|
||||
(:i1+ (index)
|
||||
(lap-operands 'runtime\ i1+ index))
|
||||
(:i+ (index1 index2)
|
||||
(lap-operands 'runtime\ i+ index1 index2))
|
||||
(:i- (index1 index2)
|
||||
(lap-operands 'runtime\ i- index1 index2))
|
||||
(:ilogand (index1 index2)
|
||||
(lap-operands 'runtime\ ilogand index1 index2))
|
||||
(:ilogxor (index1 index2)
|
||||
(lap-operands 'runtime\ ilogxor index1 index2))
|
||||
(:iref (vector index)
|
||||
(lap-operands 'runtime\ iref vector index))
|
||||
(:iset (vector index value)
|
||||
(lap-operands 'runtime\ iset vector index value))
|
||||
(:cref (vector i)
|
||||
`(runtime\ svref ,(lap-operand vector)
|
||||
,i))
|
||||
(:lisp-variable (symbol)
|
||||
symbol)
|
||||
(:lisp (form)
|
||||
form)))
|
||||
|
||||
(defun lap-operands (fn &rest regs)
|
||||
(cons fn (mapcar #'lap-operand regs)))
|
||||
|
||||
(defun lap-reg (n)
|
||||
(intern (format nil "REG~D" n)
|
||||
*the-clos-package*))
|
||||
|
||||
|
||||
;;; Runtime Implementations of the operands and opcodes. In those ports of CLOS which choose not to
|
||||
;;; completely re-implement the LAP code generator, it may still be provident to consider
|
||||
;;; reimplementing one or more of these to get the compiler to produce better code. That is why
|
||||
;;; they are split out.
|
||||
|
||||
|
||||
(proclaim '(declaration clos-fast-call))
|
||||
|
||||
(defmacro runtime\ funcall (fn &rest args)
|
||||
`(funcall ,fn ,.args))
|
||||
|
||||
(defmacro runtime\ apply (fn &rest args)
|
||||
`(apply ,fn ,.args))
|
||||
|
||||
(defmacro runtime\ std-wrapper (x)
|
||||
`(std-instance-wrapper ,x))
|
||||
|
||||
(defmacro runtime\ fsc-wrapper (x)
|
||||
`(fsc-instance-wrapper ,x))
|
||||
|
||||
(defmacro runtime\ built-in-wrapper (x)
|
||||
`(built-in-wrapper-of ,x))
|
||||
|
||||
(defmacro runtime\ structure-wrapper (x)
|
||||
`(??? ,x))
|
||||
|
||||
(defmacro runtime\ std-slots (x)
|
||||
`(std-instance-slots (the std-instance ,x)))
|
||||
|
||||
(defmacro runtime\ fsc-slots (x)
|
||||
`(fsc-instance-slots ,x))
|
||||
|
||||
(defmacro runtime\ std-instance-p (x)
|
||||
`(std-instance-p ,x))
|
||||
|
||||
(defmacro runtime\ fsc-instance-p (x)
|
||||
`(fsc-instance-p ,x))
|
||||
|
||||
(defmacro runtime\ izerop (x)
|
||||
`(zerop (the fixnum ,x)))
|
||||
|
||||
(defmacro runtime\ fix= (x y)
|
||||
`(= (the fixnum ,x)
|
||||
(the fixnum ,y)))
|
||||
|
||||
|
||||
;;; These are the implementations of the index operands. The portable assembler generates Lisp code
|
||||
;;; that uses these macros. Even though the variables holding the arguments and results have type
|
||||
;;; declarations on them, we put type declarations in here. Some compilers are so stupid...
|
||||
|
||||
|
||||
(defmacro runtime\ iref (vector index)
|
||||
`(svref (the simple-vector ,vector)
|
||||
(the fixnum ,index)))
|
||||
|
||||
(defmacro runtime\ iset (vector index value)
|
||||
`(setf (svref (the simple-vector ,vector)
|
||||
(the fixnum ,index))
|
||||
,value))
|
||||
|
||||
(defmacro runtime\ svref (vector fixnum)
|
||||
`(svref (the simple-vector ,vector)
|
||||
(the fixnum ,fixnum)))
|
||||
|
||||
(defmacro runtime\ i+ (index1 index2)
|
||||
`(the fixnum (+ (the fixnum ,index1)
|
||||
(the fixnum ,index2))))
|
||||
|
||||
(defmacro runtime\ i- (index1 index2)
|
||||
`(the fixnum (- (the fixnum ,index1)
|
||||
(the fixnum ,index2))))
|
||||
|
||||
(defmacro runtime\ i1+ (index)
|
||||
`(the fixnum (1+ (the fixnum ,index))))
|
||||
|
||||
(defmacro runtime\ ilogand (index1 index2)
|
||||
`(the fixnum (logand (the fixnum ,index1)
|
||||
(the fixnum ,index2))))
|
||||
|
||||
(defmacro runtime\ ilogxor (index1 index2)
|
||||
`(the fixnum (logxor (the fixnum ,index1)
|
||||
(the fixnum ,index2))))
|
||||
|
||||
|
||||
;;; In the portable implementation, indexes are just fixnums.
|
||||
|
||||
|
||||
(defconstant index-value-limit most-positive-fixnum)
|
||||
|
||||
(defun index-value->index (index-value)
|
||||
index-value)
|
||||
|
||||
(defun index->index-value (index)
|
||||
index)
|
||||
|
||||
(defun make-index-mask (cache-size line-size)
|
||||
(let ((cache-size-in-bits (floor (log cache-size 2)))
|
||||
(line-size-in-bits (floor (log line-size 2)))
|
||||
(mask 0))
|
||||
(dotimes (i cache-size-in-bits)
|
||||
(setq mask (dpb 1 (byte 1 i)
|
||||
mask)))
|
||||
(dotimes (i line-size-in-bits)
|
||||
(setq mask (dpb 0 (byte 1 i)
|
||||
mask)))
|
||||
mask))
|
||||
@@ -1,3 +0,0 @@
|
||||
;;
|
||||
|
||||
(CLOS::PRECOMPILE-RANDOM-CODE-SEGMENTS BROWSER)
|
||||
@@ -1,31 +0,0 @@
|
||||
;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
|
||||
;;;
|
||||
;;; *************************************************************************
|
||||
;;; Copyright (c) 1991 Venue
|
||||
;;; All rights reserved.
|
||||
;;; *************************************************************************
|
||||
;;;
|
||||
|
||||
(in-package 'clos)
|
||||
|
||||
;;;
|
||||
;;; pre-allocate generic function caches. The hope is that this will put
|
||||
;;; them nicely together in memory, and that that may be a win. Of course
|
||||
;;; the first gc copy will probably blow that out, this really wants to be
|
||||
;;; wrapped in something that declares the area static.
|
||||
;;;
|
||||
;;; This preallocation only creates about 25% more caches than CLOS itself
|
||||
;;; uses need. Some ports may want to preallocate some more of these.
|
||||
;;;
|
||||
(eval-when (load)
|
||||
(flet ((allocate (n size)
|
||||
(mapcar #'free-cache
|
||||
(mapcar #'get-cache
|
||||
(make-list n :initial-element size)))))
|
||||
(allocate 128 4)
|
||||
(allocate 64 8)
|
||||
(allocate 64 9)
|
||||
(allocate 32 16)
|
||||
(allocate 16 17)
|
||||
(allocate 16 32)
|
||||
(allocate 1 64)))
|
||||
@@ -1,12 +0,0 @@
|
||||
;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
|
||||
;;;
|
||||
;;; *************************************************************************
|
||||
;;; Copyright (c) 1991 Venue
|
||||
;;; All rights reserved.
|
||||
;;; *************************************************************************
|
||||
;;;
|
||||
|
||||
(in-package 'clos)
|
||||
|
||||
(precompile-dfun-constructors clos) ;this is half of a call to
|
||||
;precompile-random-code-segments
|
||||
@@ -1,12 +0,0 @@
|
||||
;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
|
||||
;;;
|
||||
;;; *************************************************************************
|
||||
;;; Copyright (c) 1991 Venue
|
||||
;;; All rights reserved.
|
||||
;;; *************************************************************************
|
||||
;;;
|
||||
|
||||
(in-package 'clos)
|
||||
|
||||
(precompile-function-generators clos) ;this is half of a call to
|
||||
;precompile-random-code-segments
|
||||
@@ -1,261 +0,0 @@
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
;;; These four functions work on std-instances and fsc-instances. These are instances for which it
|
||||
;;; is possible to change the wrapper and the slots. For these kinds of instances, most specified
|
||||
;;; methods from the instance structure protocol are promoted to the implementation-specific class
|
||||
;;; std-class. Many of these methods call these four functions.
|
||||
|
||||
|
||||
(defun get-wrapper (inst)
|
||||
(cond ((std-instance-p inst)
|
||||
(std-instance-wrapper inst))
|
||||
((fsc-instance-p inst)
|
||||
(fsc-instance-wrapper inst))
|
||||
(t (error "What kind of instance is this?"))))
|
||||
|
||||
(defun get-slots (inst)
|
||||
(cond ((std-instance-p inst)
|
||||
(std-instance-slots inst))
|
||||
((fsc-instance-p inst)
|
||||
(fsc-instance-slots inst))
|
||||
(t (error "What kind of instance is this?"))))
|
||||
|
||||
(defun set-wrapper (inst new)
|
||||
(cond ((std-instance-p inst)
|
||||
(setf (std-instance-wrapper inst)
|
||||
new))
|
||||
((fsc-instance-p inst)
|
||||
(setf (fsc-instance-wrapper inst)
|
||||
new))
|
||||
(t (error "What kind of instance is this?"))))
|
||||
|
||||
(defun set-slots (inst new)
|
||||
(cond ((std-instance-p inst)
|
||||
(setf (std-instance-slots inst)
|
||||
new))
|
||||
((fsc-instance-p inst)
|
||||
(setf (fsc-instance-slots inst)
|
||||
new))
|
||||
(t (error "What kind of instance is this?"))))
|
||||
|
||||
(defmacro get-slot-value-2 (instance wrapper slot-name slots index)
|
||||
`(let ((val (%svref ,slots ,index)))
|
||||
(if (eq val ',*slot-unbound*)
|
||||
(slot-unbound (wrapper-class ,wrapper)
|
||||
,instance
|
||||
,slot-name)
|
||||
val)))
|
||||
|
||||
(defmacro set-slot-value-2 (nv instance wrapper slot-name slots index)
|
||||
(declare (ignore instance wrapper slot-name))
|
||||
`(setf (%svref ,slots ,index)
|
||||
,nv))
|
||||
|
||||
(defun get-class-slot-value-1 (object wrapper slot-name)
|
||||
(let ((entry (assq slot-name (wrapper-class-slots wrapper))))
|
||||
(if (null entry)
|
||||
(slot-missing (wrapper-class wrapper)
|
||||
object slot-name 'slot-value)
|
||||
(if (eq (cdr entry)
|
||||
*slot-unbound*)
|
||||
(slot-unbound (wrapper-class wrapper)
|
||||
object slot-name)
|
||||
(cdr entry)))))
|
||||
|
||||
(defun set-class-slot-value-1 (new-value object wrapper slot-name)
|
||||
(let ((entry (assq slot-name (wrapper-class-slots wrapper))))
|
||||
(if (null entry)
|
||||
(slot-missing (wrapper-class wrapper)
|
||||
object slot-name 'setf new-value)
|
||||
(setf (cdr entry)
|
||||
new-value))))
|
||||
|
||||
(defmethod class-slot-value ((class std-class)
|
||||
slot-name)
|
||||
(let ((wrapper (class-wrapper class))
|
||||
(prototype (class-prototype class)))
|
||||
(get-class-slot-value-1 prototype wrapper slot-name)))
|
||||
|
||||
(defmethod (setf class-slot-value)
|
||||
(nv (class std-class)
|
||||
slot-name)
|
||||
(let ((wrapper (class-wrapper class))
|
||||
(prototype (class-prototype class)))
|
||||
(set-class-slot-value-1 nv prototype wrapper slot-name)))
|
||||
|
||||
(defmethod find-slot-definition ((class std-class)
|
||||
slot-name)
|
||||
(if (and (eq class *the-class-standard-class*)
|
||||
(eq slot-name 'slots))
|
||||
*the-eslotd-standard-class-slots*
|
||||
(progn (unless (class-finalized-p class)
|
||||
(finalize-inheritance class))
|
||||
(dolist (eslotd (class-slots class))
|
||||
(when (eq (slotd-name eslotd)
|
||||
slot-name)
|
||||
(return eslotd))))))
|
||||
|
||||
(defun slot-value (object slot-name)
|
||||
(let ((class (class-of object)))
|
||||
(if (eq class *the-class-standard-effective-slot-definition*)
|
||||
(let* ((wrapper (check-wrapper-validity object))
|
||||
(slots (get-slots object))
|
||||
(index (instance-slot-index wrapper slot-name)))
|
||||
(if index
|
||||
(get-slot-value-2 object wrapper slot-name slots index)
|
||||
(get-class-slot-value-1 object wrapper slot-name)))
|
||||
(let ((slot-definition (find-slot-definition class slot-name)))
|
||||
(if (null slot-definition)
|
||||
(slot-missing class object slot-name 'slot-value)
|
||||
(slot-value-using-class class object slot-definition))))))
|
||||
|
||||
(defun set-slot-value (object slot-name new-value)
|
||||
(let ((class (class-of object)))
|
||||
(if (eq class *the-class-standard-effective-slot-definition*)
|
||||
(let* ((wrapper (check-wrapper-validity object))
|
||||
(slots (get-slots object))
|
||||
(index (instance-slot-index wrapper slot-name)))
|
||||
(if index
|
||||
(set-slot-value-2 new-value object wrapper slot-name slots index)
|
||||
(set-class-slot-value-1 new-value object wrapper slot-name)))
|
||||
(let ((slot-definition (find-slot-definition class slot-name)))
|
||||
(if (null slot-definition)
|
||||
(slot-missing class object slot-name 'setf)
|
||||
(setf (slot-value-using-class class object slot-definition)
|
||||
new-value))))))
|
||||
|
||||
(defun slot-boundp (object slot-name)
|
||||
(let* ((class (class-of object))
|
||||
(slot-definition (find-slot-definition class slot-name)))
|
||||
(if (null slot-definition)
|
||||
(slot-missing class object slot-name 'slot-boundp)
|
||||
(slot-boundp-using-class class object slot-definition))))
|
||||
|
||||
(defun slot-makunbound (object slot-name)
|
||||
(let* ((class (class-of object))
|
||||
(slot-definition (find-slot-definition class slot-name)))
|
||||
(if (null slot-definition)
|
||||
(slot-missing class object slot-name 'slot-makunbound)
|
||||
(slot-makunbound-using-class class object slot-definition))))
|
||||
|
||||
(defun slot-exists-p (object slot-name)
|
||||
(let* ((class (class-of object))
|
||||
(slot-definition (find-slot-definition class slot-name)))
|
||||
(and slot-definition (slot-exists-p-using-class class object slot-definition))))
|
||||
|
||||
|
||||
;;; This isn't documented, but is used within CLOS in a number of print object methods (see
|
||||
;;; named-object-print-function).
|
||||
|
||||
|
||||
(defun slot-value-or-default (object slot-name &optional (default "unbound"))
|
||||
(if (slot-boundp object slot-name)
|
||||
(slot-value object slot-name)
|
||||
default))
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
(defmethod slot-value-using-class ((class std-class)
|
||||
(object standard-object)
|
||||
(slotd standard-effective-slot-definition))
|
||||
(let* ((wrapper (check-wrapper-validity object))
|
||||
; trap if need be
|
||||
(slots (get-slots object))
|
||||
(slot-name (slotd-name slotd))
|
||||
(index (or (slotd-instance-index slotd)
|
||||
(setf (slotd-instance-index slotd)
|
||||
(instance-slot-index wrapper slot-name)))))
|
||||
(if index
|
||||
(get-slot-value-2 object wrapper slot-name slots index)
|
||||
(get-class-slot-value-1 object wrapper slot-name))))
|
||||
|
||||
(defmethod (setf slot-value-using-class)
|
||||
(new-value (class std-class)
|
||||
(object standard-object)
|
||||
(slotd standard-effective-slot-definition))
|
||||
(let* ((wrapper (check-wrapper-validity object))
|
||||
; trap if need be
|
||||
(slots (get-slots object))
|
||||
(slot-name (slotd-name slotd))
|
||||
(index (or (slotd-instance-index slotd)
|
||||
(setf (slotd-instance-index slotd)
|
||||
(instance-slot-index wrapper slot-name)))))
|
||||
(if index
|
||||
(set-slot-value-2 new-value object wrapper slot-name slots index)
|
||||
(set-class-slot-value-1 new-value object wrapper slot-name))))
|
||||
|
||||
(defmethod slot-boundp-using-class ((class std-class)
|
||||
(object standard-object)
|
||||
(slotd standard-effective-slot-definition))
|
||||
(let* ((wrapper (check-wrapper-validity object))
|
||||
; trap if need be
|
||||
(slots (get-slots object))
|
||||
(slot-name (slotd-name slotd))
|
||||
(index (or (slotd-instance-index slotd)
|
||||
(setf (slotd-instance-index slotd)
|
||||
(instance-slot-index wrapper slot-name)))))
|
||||
(if index
|
||||
(neq (svref slots index)
|
||||
*slot-unbound*)
|
||||
(let ((entry (assq slot-name (wrapper-class-slots wrapper))))
|
||||
(if (null entry)
|
||||
(slot-missing class object slot-name 'slot-boundp)
|
||||
(neq (cdr entry)
|
||||
*slot-unbound*))))))
|
||||
|
||||
(defmethod slot-makunbound-using-class ((class std-class)
|
||||
(object standard-object)
|
||||
(slotd standard-effective-slot-definition))
|
||||
(let* ((wrapper (check-wrapper-validity object))
|
||||
; trap if need be
|
||||
(slots (get-slots object))
|
||||
(slot-name (slotd-name slotd))
|
||||
(index (or (slotd-instance-index slotd)
|
||||
(setf (slotd-instance-index slotd)
|
||||
(instance-slot-index wrapper slot-name)))))
|
||||
(cond (index (setf (%svref slots index)
|
||||
*slot-unbound*)
|
||||
object)
|
||||
(t (let ((entry (assq slot-name (wrapper-class-slots wrapper))))
|
||||
(if* (null entry)
|
||||
(slot-missing class object slot-name 'slot-makunbound)
|
||||
(setf (cdr entry)
|
||||
*slot-unbound*)
|
||||
object))))))
|
||||
|
||||
(defmethod slot-exists-p-using-class ((class std-class)
|
||||
(object standard-object)
|
||||
(slotd standard-effective-slot-definition))
|
||||
t)
|
||||
|
||||
(defmethod slot-missing ((class t)
|
||||
instance slot-name operation &optional new-value)
|
||||
(error "When attempting to ~A,~%the slot ~S is missing from the object ~S."
|
||||
(ecase operation
|
||||
(slot-value "read the slot's value (slot-value)")
|
||||
(setf (format nil "set the slot's value to ~S (setf of slot-value)" new-value))
|
||||
(slot-boundp "test to see if slot is bound (slot-boundp)")
|
||||
(slot-makunbound "make the slot unbound (slot-makunbound)"))
|
||||
slot-name instance))
|
||||
|
||||
(defmethod slot-unbound ((class t)
|
||||
instance slot-name)
|
||||
(error "The slot ~S is unbound in the object ~S." slot-name instance))
|
||||
|
||||
(defmethod allocate-instance ((class standard-class)
|
||||
&rest initargs)
|
||||
(declare (ignore initargs))
|
||||
(unless (class-finalized-p class)
|
||||
(finalize-inheritance class))
|
||||
(let* ((class-wrapper (class-wrapper class))
|
||||
(instance (%allocate-instance--class (class-no-of-instance-slots class))))
|
||||
(setf (std-instance-wrapper instance)
|
||||
class-wrapper)
|
||||
instance))
|
||||
@@ -1,997 +0,0 @@
|
||||
|
||||
;;;-*- Package: CLOS; Syntax: Common-Lisp; Base: 10 -*-
|
||||
|
||||
|
||||
;;; File converted on 10-Apr-91 22:24:19 from source std-class
|
||||
;;;. Original source {dsk}<usr>local>users>welch>lisp>clos>rev4>il-format>std-class.;4 created 20-Feb-91 13:07:14
|
||||
|
||||
;;;. Copyright (c) 1991 by Venue
|
||||
|
||||
|
||||
(in-package "CLOS")
|
||||
|
||||
|
||||
|
||||
(define-gf-predicate classp class)
|
||||
|
||||
(define-gf-predicate standard-class-p standard-class)
|
||||
|
||||
(define-gf-predicate forward-referenced-class-p forward-referenced-class)
|
||||
|
||||
(defmethod shared-initialize :after ((object documentation-mixin)
|
||||
slot-names &key documentation)
|
||||
(declare (ignore slot-names))
|
||||
(setf (plist-value object 'documentation)
|
||||
documentation))
|
||||
|
||||
(defmethod documentation (object &optional doc-type)
|
||||
(cl:documentation object doc-type))
|
||||
|
||||
(defmethod (setf documentation)
|
||||
(new-value object &optional doc-type)
|
||||
(declare (ignore new-value doc-type))
|
||||
(error "Can't change the documentation of ~S." object))
|
||||
|
||||
(defmethod documentation ((object documentation-mixin)
|
||||
&optional doc-type)
|
||||
(declare (ignore doc-type))
|
||||
(car (plist-value object 'documentation)))
|
||||
|
||||
(defmethod (setf documentation)
|
||||
(new-value (object documentation-mixin)
|
||||
&optional doc-type)
|
||||
(declare (ignore doc-type))
|
||||
(setf (plist-value object 'documentation)
|
||||
new-value))
|
||||
|
||||
(defmethod documentation ((slotd standard-slot-definition)
|
||||
&optional doc-type)
|
||||
(declare (ignore doc-type))
|
||||
(slot-value slotd 'documentation))
|
||||
|
||||
(defmethod (setf documentation)
|
||||
(new-value (slotd standard-slot-definition)
|
||||
&optional doc-type)
|
||||
(declare (ignore doc-type))
|
||||
(setf (slot-value slotd 'documentation)
|
||||
new-value))
|
||||
|
||||
(defmethod documentation ((method standard-method) &optional doc-type)
|
||||
(declare (ignore doc-type))
|
||||
(plist-value method 'documentation))
|
||||
|
||||
(defmethod (setf documentation)
|
||||
(new-value (method standard-method)
|
||||
&optional doc-type)
|
||||
(declare (ignore doc-type))
|
||||
(setf (plist-value method 'documentation) new-value))
|
||||
|
||||
;;; Various class accessors that are a little more complicated than can be done with automatically
|
||||
;;; generated reader methods.
|
||||
|
||||
|
||||
(defmethod class-wrapper ((class clos-class))
|
||||
(with-slots (wrapper)
|
||||
class
|
||||
(let ((w? wrapper))
|
||||
(if (consp w?)
|
||||
(let ((new (make-wrapper class)))
|
||||
(setf (wrapper-instance-slots-layout new)
|
||||
(car w?)
|
||||
(wrapper-class-slots new)
|
||||
(cdr w?))
|
||||
(setq wrapper new))
|
||||
w?))))
|
||||
|
||||
(defmethod class-precedence-list ((class clos-class))
|
||||
(unless (class-finalized-p class)
|
||||
(finalize-inheritance class))
|
||||
(with-slots (class-precedence-list)
|
||||
class
|
||||
class-precedence-list))
|
||||
|
||||
(defmethod class-finalized-p ((class clos-class))
|
||||
(with-slots (wrapper)
|
||||
class
|
||||
(not (null wrapper))))
|
||||
|
||||
(defmethod class-prototype ((class std-class))
|
||||
(with-slots (prototype)
|
||||
class
|
||||
(or prototype (setq prototype (allocate-instance class)))))
|
||||
|
||||
(defmethod class-direct-default-initargs ((class std-class))
|
||||
(plist-value class 'direct-default-initargs))
|
||||
|
||||
(defmethod class-default-initargs ((class std-class))
|
||||
(plist-value class 'default-initargs))
|
||||
|
||||
(defmethod class-constructors ((class std-class))
|
||||
(plist-value class 'constructors))
|
||||
|
||||
(defmethod class-slot-cells ((class std-class))
|
||||
(plist-value class 'class-slot-cells))
|
||||
|
||||
|
||||
;;; Class accessors that are even a little bit more complicated than those above. These have a
|
||||
;;; protocol for updating them, we must implement that protocol. Maintaining the direct subclasses
|
||||
;;; backpointers. The update methods are here, the values are read by an automatically generated
|
||||
;;; reader method.
|
||||
|
||||
|
||||
(defmethod add-direct-subclass ((class class)
|
||||
(subclass class))
|
||||
(with-slots (direct-subclasses)
|
||||
class
|
||||
(pushnew subclass direct-subclasses)
|
||||
subclass))
|
||||
|
||||
(defmethod remove-direct-subclass ((class class)
|
||||
(subclass class))
|
||||
(with-slots (direct-subclasses)
|
||||
class
|
||||
(setq direct-subclasses (remove subclass direct-subclasses))
|
||||
subclass))
|
||||
|
||||
|
||||
;;; Maintaining the direct-methods and direct-generic-functions backpointers. There are four generic
|
||||
;;; functions involved, each has one method for the class case and another method for the damned EQL
|
||||
;;; specializers. All of these are specified methods and appear in their specified place in the
|
||||
;;; class graph. ADD-METHOD-ON-SPECIALIZER REMOVE-METHOD-ON-SPECIALIZER SPECIALIZER-METHODS
|
||||
;;; SPECIALIZER-GENERIC-FUNCTIONS In each case, we maintain one value which is a cons. The car is
|
||||
;;; the list methods. The cdr is a list of the generic functions. The cdr is always computed
|
||||
;;; lazily.
|
||||
|
||||
|
||||
(defmethod add-method-on-specializer ((method method)
|
||||
(specializer class))
|
||||
(with-slots (direct-methods)
|
||||
specializer
|
||||
(setf (car direct-methods)
|
||||
(adjoin method (car direct-methods))
|
||||
(cdr direct-methods)
|
||||
nil))
|
||||
method)
|
||||
|
||||
(defmethod remove-method-on-specializer ((method method)
|
||||
(specializer class))
|
||||
(with-slots (direct-methods)
|
||||
specializer
|
||||
(setf (car direct-methods)
|
||||
(remove method (car direct-methods))
|
||||
(cdr direct-methods)
|
||||
nil))
|
||||
method)
|
||||
|
||||
(defmethod specializer-methods ((specializer class))
|
||||
(with-slots (direct-methods)
|
||||
specializer
|
||||
(car direct-methods)))
|
||||
|
||||
(defmethod specializer-generic-functions ((specializer class))
|
||||
(with-slots (direct-methods)
|
||||
specializer
|
||||
(or (cdr direct-methods)
|
||||
(setf (cdr direct-methods)
|
||||
(gathering1 (collecting-once)
|
||||
(dolist (m (car direct-methods))
|
||||
(gather1 (method-generic-function m))))))))
|
||||
|
||||
|
||||
;;; This hash table is used to store the direct methods and direct generic functions of EQL
|
||||
;;; specializers. Each value in the table is the cons.
|
||||
|
||||
|
||||
(defvar *eql-specializer-methods* (make-hash-table :test #'eql))
|
||||
|
||||
(defmethod add-method-on-specializer ((method method)
|
||||
(specializer eql-specializer))
|
||||
(let* ((object (eql-specializer-object specializer))
|
||||
(entry (gethash object *eql-specializer-methods*)))
|
||||
(unless entry
|
||||
(setq entry (setf (gethash object *eql-specializer-methods*)
|
||||
(cons nil nil))))
|
||||
(setf (car entry)
|
||||
(adjoin method (car entry))
|
||||
(cdr entry)
|
||||
nil)
|
||||
method))
|
||||
|
||||
(defmethod remove-method-on-specializer ((method method)
|
||||
(specializer eql-specializer))
|
||||
(let* ((object (eql-specializer-object specializer))
|
||||
(entry (gethash object *eql-specializer-methods*)))
|
||||
(when entry
|
||||
(setf (car entry)
|
||||
(remove method (car entry))
|
||||
(cdr entry)
|
||||
nil))
|
||||
method))
|
||||
|
||||
(defmethod specializer-methods ((specializer eql-specializer))
|
||||
(car (gethash (eql-specializer-object specializer)
|
||||
*eql-specializer-methods*)))
|
||||
|
||||
(defmethod specializer-generic-functions ((specializer eql-specializer))
|
||||
(let* ((object (eql-specializer-object specializer))
|
||||
(entry (gethash object *eql-specializer-methods*)))
|
||||
(when entry
|
||||
(or (cdr entry)
|
||||
(setf (cdr entry)
|
||||
(gathering1 (collecting-once)
|
||||
(dolist (m (car entry))
|
||||
(gather1 (method-generic-function m)))))))))
|
||||
|
||||
(defun real-load-defclass (name metaclass-name supers slots other accessors)
|
||||
(do-standard-defsetfs-for-defclass accessors)
|
||||
; ***
|
||||
(apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots
|
||||
slots :definition-source `((defclass ,name ()
|
||||
())
|
||||
,(load-truename))
|
||||
other))
|
||||
|
||||
(defun ensure-class (name &rest all)
|
||||
(apply #'ensure-class-using-class name (find-class name nil)
|
||||
all))
|
||||
|
||||
(defmethod ensure-class-using-class (name (class null)
|
||||
&rest args &key)
|
||||
(multiple-value-bind (meta initargs)
|
||||
(ensure-class-values class args)
|
||||
(setf class (apply #'make-instance meta :name name initargs)
|
||||
(find-class name)
|
||||
class)
|
||||
(inform-type-system-about-class class name)
|
||||
; ***
|
||||
class))
|
||||
|
||||
(defmethod ensure-class-using-class (name (class clos-class)
|
||||
&rest args &key)
|
||||
(multiple-value-bind (meta initargs)
|
||||
(ensure-class-values class args)
|
||||
(unless (eq (class-of class)
|
||||
meta)
|
||||
(change-class class meta))
|
||||
(apply #'reinitialize-instance class initargs)
|
||||
(inform-type-system-about-class class name)
|
||||
; ***
|
||||
class))
|
||||
|
||||
(defun ensure-class-values (class args)
|
||||
(let* ((initargs (copy-list args))
|
||||
(unsupplied (list 1))
|
||||
(supplied-meta (getf initargs :metaclass unsupplied))
|
||||
(supplied-supers (getf initargs :direct-superclasses unsupplied))
|
||||
(supplied-slots (getf initargs :direct-slots unsupplied))
|
||||
(meta (cond ((neq supplied-meta unsupplied)
|
||||
(find-class supplied-meta))
|
||||
((or (null class)
|
||||
(forward-referenced-class-p class))
|
||||
*the-class-standard-class*)
|
||||
(t (class-of class))))
|
||||
(proto (class-prototype meta)))
|
||||
(flet ((fix-super (s)
|
||||
(cond ((classp s)
|
||||
s)
|
||||
((not (legal-class-name-p s))
|
||||
(error "~S is not a class or a legal class name." s))
|
||||
(t (or (find-class s nil)
|
||||
(setf (find-class s)
|
||||
(make-instance 'forward-referenced-class :name s)))))))
|
||||
(loop (unless (remf initargs :metaclass)
|
||||
(return)))
|
||||
(loop (unless (remf initargs :direct-superclasses)
|
||||
(return)))
|
||||
(loop (unless (remf initargs :direct-slots)
|
||||
(return)))
|
||||
(values meta (list* :direct-superclasses (and (neq supplied-supers unsupplied)
|
||||
(mapcar #'fix-super supplied-supers)
|
||||
)
|
||||
:direct-slots
|
||||
(and (neq supplied-slots unsupplied)
|
||||
supplied-slots)
|
||||
initargs)))))
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
(defmethod shared-initialize :before ((class std-class)
|
||||
slot-names &key direct-superclasses)
|
||||
(declare (ignore slot-names))
|
||||
|
||||
;; *** error checking
|
||||
)
|
||||
|
||||
(defmethod shared-initialize :after ((class std-class)
|
||||
slot-names
|
||||
&key (direct-superclasses
|
||||
nil direct-superclasses-p)
|
||||
(direct-slots nil direct-slots-p)
|
||||
(direct-default-initargs
|
||||
nil direct-default-initargs-p))
|
||||
(declare (ignore slot-names))
|
||||
(setq direct-superclasses (if direct-superclasses-p
|
||||
(setf (slot-value class 'direct-superclasses)
|
||||
(or direct-superclasses
|
||||
(list *the-class-standard-object*)
|
||||
))
|
||||
(slot-value class 'direct-superclasses)))
|
||||
(setq direct-slots (if direct-slots-p
|
||||
(setf (slot-value class 'direct-slots)
|
||||
(mapcar #'(lambda (pl)
|
||||
(make-direct-slotd class pl))
|
||||
direct-slots))
|
||||
(slot-value class 'direct-slots)))
|
||||
(if direct-default-initargs-p
|
||||
(setf (plist-value class 'direct-default-initargs)
|
||||
direct-default-initargs)
|
||||
(setq direct-default-initargs
|
||||
(plist-value class 'direct-default-initargs)))
|
||||
(setf (plist-value class 'class-slot-cells)
|
||||
(gathering1 (collecting)
|
||||
(dolist (dslotd direct-slots)
|
||||
(when (eq (slotd-allocation dslotd)
|
||||
class)
|
||||
(let ((initfunction (slotd-initfunction dslotd)))
|
||||
(gather1 (cons (slotd-name dslotd)
|
||||
(if initfunction
|
||||
(funcall initfunction)
|
||||
*slot-unbound*))))))))
|
||||
(add-direct-subclasses class direct-superclasses)
|
||||
(add-slot-accessors class direct-slots))
|
||||
|
||||
(defmethod reinitialize-instance :before ((class std-class)
|
||||
&key direct-superclasses direct-slots
|
||||
direct-default-initargs)
|
||||
(declare (ignore direct-default-initargs))
|
||||
(remove-direct-subclasses class (class-direct-superclasses class))
|
||||
(remove-slot-accessors class (class-direct-slots class)))
|
||||
|
||||
(defmethod reinitialize-instance :after ((class std-class)
|
||||
&rest initargs &key)
|
||||
(update-class class nil)
|
||||
(map-dependents class #'(lambda (dependent)
|
||||
(apply #'update-dependent class dependent initargs))))
|
||||
|
||||
(defun add-slot-accessors (class dslotds)
|
||||
(fix-slot-accessors class dslotds 'add))
|
||||
|
||||
(defun remove-slot-accessors (class dslotds)
|
||||
(fix-slot-accessors class dslotds 'remove))
|
||||
|
||||
(defun fix-slot-accessors (class dslotds add/remove)
|
||||
(flet ((fix (gfspec name r/w)
|
||||
(let ((gf (ensure-generic-function gfspec)))
|
||||
(case r/w
|
||||
(r (if (eq add/remove 'add)
|
||||
(add-reader-method class gf name)
|
||||
(remove-reader-method class gf)))
|
||||
(w (if (eq add/remove 'add)
|
||||
(add-writer-method class gf name)
|
||||
(remove-writer-method class gf)))))))
|
||||
(dolist (dslotd dslotds)
|
||||
(let ((slot-name (slotd-name dslotd)))
|
||||
(dolist (r (slotd-readers dslotd))
|
||||
(fix r slot-name 'r))
|
||||
(dolist (w (slotd-writers dslotd))
|
||||
(fix w slot-name 'w))))))
|
||||
|
||||
(defun add-direct-subclasses (class new)
|
||||
(dolist (n new)
|
||||
(unless (memq class (class-direct-subclasses class))
|
||||
(add-direct-subclass n class))))
|
||||
|
||||
(defun remove-direct-subclasses (class new)
|
||||
(let ((old (class-direct-superclasses class)))
|
||||
(dolist (o (set-difference old new))
|
||||
(remove-direct-subclass o class))))
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
(defmethod finalize-inheritance ((class std-class))
|
||||
(update-class class t))
|
||||
|
||||
|
||||
;;; Called by :after reinitialize instance whenever a class is reinitialized. The class may or may
|
||||
;;; not be finalized.
|
||||
|
||||
|
||||
(defun update-class (class finalizep)
|
||||
(when (or finalizep (class-finalized-p class))
|
||||
(let* ((dsupers (class-direct-superclasses class))
|
||||
(dslotds (class-direct-slots class))
|
||||
(dinits (class-direct-default-initargs class))
|
||||
(cpl (compute-class-precedence-list class dsupers))
|
||||
(eslotds (compute-slots class cpl dslotds))
|
||||
(inits (compute-default-initargs class cpl dinits)))
|
||||
(update-cpl class cpl)
|
||||
(update-slots class cpl eslotds)
|
||||
(update-dinits class dinits)
|
||||
(update-inits class inits)
|
||||
(update-constructors class)))
|
||||
(unless finalizep
|
||||
(dolist (sub (class-direct-subclasses class))
|
||||
(update-class sub nil))))
|
||||
|
||||
(defun update-cpl (class cpl)
|
||||
(when (class-finalized-p class)
|
||||
(unless (equal (class-precedence-list class)
|
||||
cpl)
|
||||
(force-cache-flushes class)))
|
||||
(setf (slot-value class 'class-precedence-list)
|
||||
cpl))
|
||||
|
||||
(defun update-slots (class cpl eslotds)
|
||||
(multiple-value-bind (nlayout nwrapper-class-slots)
|
||||
(compute-storage-info cpl eslotds)
|
||||
|
||||
;; If there is a change in the shape of the instances then the old class is now obsolete.
|
||||
(let* ((owrapper (class-wrapper class))
|
||||
(olayout (and owrapper (wrapper-instance-slots-layout owrapper)))
|
||||
(owrapper-class-slots (and owrapper (wrapper-class-slots owrapper)))
|
||||
(nwrapper (cond ((null owrapper)
|
||||
(make-wrapper class))
|
||||
((and (equal nlayout olayout)
|
||||
(not (iterate ((o (list-elements owrapper-class-slots))
|
||||
(n (list-elements nwrapper-class-slots)))
|
||||
(unless (eq (car o)
|
||||
(car n))
|
||||
(return t)))))
|
||||
owrapper)
|
||||
(t
|
||||
|
||||
;; This will initialize the new wrapper to have the same state as
|
||||
;; the old wrapper. We will then have to change that. This may
|
||||
;; seem like wasted work (it is), but the spec requires that we
|
||||
;; call make-instances-obsolete.
|
||||
(make-instances-obsolete class)
|
||||
(class-wrapper class)))))
|
||||
(with-slots (wrapper no-of-instance-slots slots)
|
||||
class
|
||||
(setf no-of-instance-slots (length nlayout)
|
||||
slots eslotds (wrapper-instance-slots-layout nwrapper)
|
||||
nlayout
|
||||
(wrapper-class-slots nwrapper)
|
||||
nwrapper-class-slots wrapper nwrapper))
|
||||
(dolist (eslotd eslotds)
|
||||
(setf (slotd-class eslotd)
|
||||
class)
|
||||
(setf (slotd-instance-index eslotd)
|
||||
(instance-slot-index nwrapper (slotd-name eslotd)))))))
|
||||
|
||||
(defun compute-storage-info (cpl eslotds)
|
||||
(let ((instance nil)
|
||||
(class nil))
|
||||
(dolist (eslotd eslotds)
|
||||
(let ((alloc (slotd-allocation eslotd)))
|
||||
(cond ((eq alloc :instance)
|
||||
(push eslotd instance))
|
||||
((classp alloc)
|
||||
(push eslotd class)))))
|
||||
(values (compute-layout cpl instance)
|
||||
(compute-class-slots class))))
|
||||
|
||||
(defun compute-layout (cpl instance-eslotds)
|
||||
(let* ((names (gathering1 (collecting)
|
||||
(dolist (eslotd instance-eslotds)
|
||||
(when (eq (slotd-allocation eslotd)
|
||||
:instance)
|
||||
(gather1 (slotd-name eslotd))))))
|
||||
(order nil))
|
||||
(labels ((rwalk (tail)
|
||||
(when tail
|
||||
(rwalk (cdr tail))
|
||||
(dolist (ss (class-slots (car tail)))
|
||||
(let ((n (slotd-name ss)))
|
||||
(when (memq n names)
|
||||
(setq order (cons n order)
|
||||
names
|
||||
(remove n names))))))))
|
||||
(rwalk cpl)
|
||||
(reverse (append names order)))))
|
||||
|
||||
(defun compute-class-slots (eslotds)
|
||||
(gathering1 (collecting)
|
||||
(dolist (eslotd eslotds)
|
||||
(gather1 (assoc (slotd-name eslotd)
|
||||
(class-slot-cells (slotd-allocation eslotd)))))))
|
||||
(defun update-dinits (class dinits)
|
||||
(setf (plist-value class 'direct-default-initargs)
|
||||
(remove-invalid dinits (class-slots class))))
|
||||
|
||||
(defun update-inits (class inits)
|
||||
(setf (plist-value class 'default-initargs)
|
||||
(remove-invalid inits (class-slots class))))
|
||||
|
||||
;; bug: :default-initargs aren't updated with slots are removed, so
|
||||
;; update-inits removes initargs that don't have corresponding slots.
|
||||
|
||||
(defun remove-invalid (inits slotds &aux (return nil))
|
||||
(dolist (element inits)
|
||||
(dolist (slotd slotds)
|
||||
(if (member (car element) (slot-value slotd 'initargs))
|
||||
(pushnew element return))))
|
||||
return)
|
||||
|
||||
|
||||
|
||||
(defmethod compute-default-initargs ((class std-class)
|
||||
cpl direct)
|
||||
(labels ((walk (tail)
|
||||
(if (null tail)
|
||||
nil
|
||||
(let ((c (pop tail)))
|
||||
(append (if (eq c class)
|
||||
direct
|
||||
(class-direct-default-initargs c))
|
||||
(walk tail))))))
|
||||
(let ((initargs (walk cpl)))
|
||||
(delete-duplicates initargs
|
||||
:test #'eq :key #'car :from-end t))))
|
||||
|
||||
|
||||
;;; Protocols for constructing direct and effective slot definitions.
|
||||
|
||||
|
||||
(defmethod direct-slot-definition-class ((class std-class)
|
||||
initargs)
|
||||
(declare (ignore initargs))
|
||||
(find-class 'standard-direct-slot-definition))
|
||||
|
||||
(defun make-direct-slotd (class initargs)
|
||||
(let ((initargs (list* :class class initargs)))
|
||||
(apply #'make-instance (direct-slot-definition-class class initargs)
|
||||
initargs)))
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
(defmethod compute-slots ((class std-class)
|
||||
cpl class-direct-slots)
|
||||
|
||||
;; As specified, we must call COMPUTE-EFFECTIVE-SLOT-DEFINITION once for each different slot
|
||||
;; name we find in our superclasses. Each call receives the class and a list of the dslotds
|
||||
;; with that name. The list is in most-specific-first order.
|
||||
(let ((name-dslotds-alist nil))
|
||||
(labels ((collect-one-class (dslotds)
|
||||
(dolist (d dslotds)
|
||||
(let* ((name (slotd-name d))
|
||||
(entry (assq name name-dslotds-alist)))
|
||||
(if entry
|
||||
(push d (cdr entry))
|
||||
(push (list name d)
|
||||
name-dslotds-alist))))))
|
||||
(collect-one-class class-direct-slots)
|
||||
(dolist (c (cdr cpl))
|
||||
(collect-one-class (class-direct-slots c)))
|
||||
(mapcar #'(lambda (direct)
|
||||
(compute-effective-slot-definition class (nreverse (cdr direct)))
|
||||
)
|
||||
name-dslotds-alist))))
|
||||
|
||||
(defmethod compute-effective-slot-definition ((class std-class)
|
||||
dslotds)
|
||||
(let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
|
||||
(class (effective-slot-definition-class class initargs)))
|
||||
(apply #'make-instance class initargs)))
|
||||
|
||||
(defmethod effective-slot-definition-class ((class std-class)
|
||||
initargs)
|
||||
(declare (ignore initargs))
|
||||
(find-class 'standard-effective-slot-definition))
|
||||
|
||||
(defmethod compute-effective-slot-definition-initargs ((class std-class)
|
||||
direct-slotds)
|
||||
(let* ((name nil)
|
||||
(initfunction nil)
|
||||
(initform nil)
|
||||
(initargs nil)
|
||||
(allocation nil)
|
||||
(type t)
|
||||
(namep nil)
|
||||
(initp nil)
|
||||
(allocp nil))
|
||||
(dolist (slotd direct-slotds)
|
||||
(when slotd
|
||||
(unless namep
|
||||
(setq name (slotd-name slotd)
|
||||
namep t))
|
||||
(unless initp
|
||||
(when (slotd-initfunction slotd)
|
||||
(setq initform (slotd-initform slotd)
|
||||
initfunction
|
||||
(slotd-initfunction slotd)
|
||||
initp t)))
|
||||
(unless allocp
|
||||
(setq allocation (slotd-allocation slotd)
|
||||
allocp t))
|
||||
(setq initargs (append (slotd-initargs slotd)
|
||||
initargs))
|
||||
(let ((slotd-type (slotd-type slotd)))
|
||||
(setq type (cond ((null type)
|
||||
slotd-type)
|
||||
((subtypep type slotd-type)
|
||||
type)
|
||||
(t `(and ,type ,slotd-type)))))))
|
||||
(list :name name :initform initform :initfunction initfunction :initargs initargs
|
||||
:allocation allocation :type type)))
|
||||
|
||||
|
||||
;;; NOTE: For bootstrapping considerations, these can't use make-instance to make the method object.
|
||||
;;; They have to use make-a-method which is a specially bootstrapped mechanism for making standard
|
||||
;;; methods.
|
||||
|
||||
|
||||
(defmethod add-reader-method ((class std-class)
|
||||
generic-function slot-name)
|
||||
(let* ((name (class-name class))
|
||||
(method (make-a-method 'standard-reader-method nil (list (or name 'standard-object))
|
||||
(list class)
|
||||
(make-reader-method-function class slot-name)
|
||||
"automatically generated reader method" slot-name)))
|
||||
(add-method generic-function method)))
|
||||
|
||||
(defmethod add-writer-method ((class std-class)
|
||||
generic-function slot-name)
|
||||
(let* ((name (class-name class))
|
||||
(method (make-a-method 'standard-writer-method nil (list 'new-value (or name
|
||||
|
||||
'
|
||||
standard-object
|
||||
))
|
||||
(list *the-class-t* class)
|
||||
(make-writer-method-function class slot-name)
|
||||
"automatically generated writer method" slot-name)))
|
||||
(add-method generic-function method)))
|
||||
|
||||
(defmethod remove-reader-method ((class std-class)
|
||||
generic-function)
|
||||
(let ((method (get-method generic-function nil (list class)
|
||||
nil)))
|
||||
(when method (remove-method generic-function method))))
|
||||
|
||||
(defmethod remove-writer-method ((class std-class)
|
||||
generic-function)
|
||||
(let ((method (get-method generic-function nil (list *the-class-t* class)
|
||||
nil)))
|
||||
(when method (remove-method generic-function method))))
|
||||
|
||||
|
||||
;;; make-reader-method-function and make-write-method function are NOT part of the standard
|
||||
;;; protocol. They are however useful, CLOS makes uses makes use of them internally and documents
|
||||
;;; them for CLOS users. *** This needs work to make type testing by the writer functions which ***
|
||||
;;; do type testing faster. The idea would be to have one constructor *** for each possible type
|
||||
;;; test. In order to do this it would be nice *** to have help from inform-type-system-about-class
|
||||
;;; and friends. *** There is a subtle bug here which is going to have to be fixed. *** Namely, the
|
||||
;;; simplistic use of the template has to be fixed. We *** have to give the optimize-slot-value
|
||||
;;; method the user might have *** defined for this metclass a chance to run.
|
||||
|
||||
|
||||
(defmethod make-reader-method-function ((class standard-class)
|
||||
slot-name)
|
||||
(make-std-reader-method-function slot-name))
|
||||
|
||||
(defmethod make-writer-method-function ((class standard-class)
|
||||
slot-name)
|
||||
(make-std-writer-method-function slot-name))
|
||||
|
||||
(defun make-std-reader-method-function (slot-name)
|
||||
#'(lambda (instance)
|
||||
(slot-value instance slot-name)))
|
||||
|
||||
(defun make-std-writer-method-function (slot-name)
|
||||
#'(lambda (nv instance)
|
||||
(setf (slot-value instance slot-name)
|
||||
nv)))
|
||||
|
||||
; inform-type-system-about-class
|
||||
; make-type-predicate
|
||||
|
||||
|
||||
|
||||
;;; These are NOT part of the standard protocol. They are internal mechanism which CLOS uses to
|
||||
;;; *try* and tell the type system about class definitions. In a more fully integrated
|
||||
;;; implementation of CLOS, the type system would know about class objects and class names in a more
|
||||
;;; fundamental way and the mechanism used to inform the type system about new classes would be
|
||||
;;; different.
|
||||
|
||||
|
||||
(defmethod inform-type-system-about-class ((class std-class)
|
||||
name)
|
||||
(let ((predicate-name (make-type-predicate-name name)))
|
||||
(setf (symbol-function predicate-name)
|
||||
(make-type-predicate name))
|
||||
(do-satisfies-deftype name predicate-name)
|
||||
(setf (gethash name lisp::*typep-hash-table*)
|
||||
predicate-name))) ;makes typep significantly faster...
|
||||
|
||||
(defun make-type-predicate (name)
|
||||
#'(lambda (x)
|
||||
(not (null (memq (find-class name)
|
||||
(cond ((std-instance-p x)
|
||||
(class-precedence-list (std-instance-class x)))
|
||||
((fsc-instance-p x)
|
||||
(class-precedence-list (fsc-instance-class x)))))))))
|
||||
|
||||
|
||||
;;; These 4 definitions appear here for bootstrapping reasons. Logically, they should be in the
|
||||
;;; construct file. For documentation purposes, a copy of these definitions appears in the
|
||||
;;; construct file. If you change one of the definitions here, be sure to change the copy there.
|
||||
|
||||
|
||||
(defvar *initialization-generic-functions* (list #'make-instance #'default-initargs
|
||||
#'allocate-instance #'initialize-instance
|
||||
#'shared-initialize))
|
||||
|
||||
(defmethod maybe-update-constructors ((generic-function generic-function)
|
||||
(method method))
|
||||
(when (memq generic-function *initialization-generic-functions*)
|
||||
(labels ((recurse (class)
|
||||
(update-constructors class)
|
||||
(dolist (subclass (class-direct-subclasses class))
|
||||
(recurse subclass))))
|
||||
(when (classp (car (method-specializers method)))
|
||||
(recurse (car (method-specializers method)))))))
|
||||
|
||||
(defmethod update-constructors ((class std-class))
|
||||
(dolist (cons (class-constructors class))
|
||||
(install-lazy-constructor-installer cons)))
|
||||
|
||||
(defmethod update-constructors ((class class))
|
||||
nil)
|
||||
|
||||
(defmethod compatible-meta-class-change-p (class proto-new-class)
|
||||
(eq (class-of class)
|
||||
(class-of proto-new-class)))
|
||||
|
||||
(defmethod check-super-metaclass-compatibility ((class t)
|
||||
(new-super t))
|
||||
(unless (eq (class-of class)
|
||||
(class-of new-super))
|
||||
(error "The class ~S was specified as a~%super-class of the class ~S;~%~
|
||||
but the meta-classes ~S and~%~S are incompatible." new-super class (class-of new-super)
|
||||
(class-of class))))
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
(defun force-cache-flushes (class)
|
||||
(let* ((owrapper (class-wrapper class))
|
||||
(state (wrapper-state owrapper)))
|
||||
|
||||
;; We only need to do something if the state is still T. If the state isn't T, it will
|
||||
;; be FLUSH or OBSOLETE, and both of those will already be doing what we want. In
|
||||
;; particular, we must be sure we never change an OBSOLETE into a FLUSH since OBSOLETE
|
||||
;; means do what FLUSH does and then some.
|
||||
(when (eq state 't)
|
||||
(let ((nwrapper (make-wrapper class)))
|
||||
(setf (wrapper-instance-slots-layout nwrapper)
|
||||
(wrapper-instance-slots-layout owrapper))
|
||||
(setf (wrapper-class-slots nwrapper)
|
||||
(wrapper-class-slots owrapper))
|
||||
(without-interrupts (setf (slot-value class 'wrapper)
|
||||
nwrapper)
|
||||
(invalidate-wrapper owrapper 'flush nwrapper))
|
||||
(update-constructors class)))))
|
||||
|
||||
; ??? ***
|
||||
|
||||
|
||||
(defun flush-cache-trap (owrapper nwrapper instance)
|
||||
(declare (ignore owrapper))
|
||||
(set-wrapper instance nwrapper))
|
||||
|
||||
|
||||
;;; make-instances-obsolete can be called by user code. It will cause the next access to the
|
||||
;;; instance (as defined in 88-002R) to trap through the update-instance-for-redefined-class
|
||||
;;; mechanism.
|
||||
|
||||
|
||||
(defmethod make-instances-obsolete ((class std-class))
|
||||
(let ((owrapper (class-wrapper class))
|
||||
(nwrapper (make-wrapper class)))
|
||||
(setf (wrapper-instance-slots-layout nwrapper)
|
||||
(wrapper-instance-slots-layout owrapper))
|
||||
(setf (wrapper-class-slots nwrapper)
|
||||
(wrapper-class-slots owrapper))
|
||||
(without-interrupts (setf (slot-value class 'wrapper)
|
||||
nwrapper)
|
||||
(invalidate-wrapper owrapper 'obsolete nwrapper)
|
||||
class)))
|
||||
|
||||
(defmethod make-instances-obsolete ((class symbol))
|
||||
(make-instances-obsolete (find-class class)))
|
||||
|
||||
|
||||
;;; obsolete-instance-trap is the internal trap that is called when we see an obsolete instance.
|
||||
;;; The times when it is called are: - when the instance is involved in method lookup - when
|
||||
;;; attempting to access a slot of an instance It is not called by class-of, wrapper-of, or any of
|
||||
;;; the low-level instance access macros. Of course these times when it is called are an internal
|
||||
;;; implementation detail of CLOS and are not part of the documented description of when the obsolete
|
||||
;;; instance update happens. The documented description is as it appears in 88-002R. This has to
|
||||
;;; return the new wrapper, so it counts on all the methods on obsolete-instance-trap-internal to
|
||||
;;; return the new wrapper. It also does a little internal error checking to make sure that the
|
||||
;;; traps are only happening when they should, and that the trap methods are computing apropriate
|
||||
;;; new wrappers.
|
||||
|
||||
|
||||
(defun obsolete-instance-trap (owrapper nwrapper instance)
|
||||
|
||||
;; local --> local transfer local --> shared discard local --> --
|
||||
;; discard shared --> local transfer shared --> shared discard shared --> --
|
||||
;; discard -- --> local add -- --> shared --
|
||||
(let* ((class (wrapper-class nwrapper))
|
||||
(guts (allocate-instance class))
|
||||
; ??? allocate-instance ???
|
||||
(olayout (wrapper-instance-slots-layout owrapper))
|
||||
(nlayout (wrapper-instance-slots-layout nwrapper))
|
||||
(oslots (get-slots instance))
|
||||
(nslots (get-slots guts))
|
||||
(oclass-slots (wrapper-class-slots owrapper))
|
||||
(added nil)
|
||||
(discarded nil)
|
||||
(plist nil))
|
||||
|
||||
;; Go through all the old local slots.
|
||||
(iterate ((name (list-elements olayout))
|
||||
(opos (interval :from 0)))
|
||||
(let ((npos (posq name nlayout)))
|
||||
(if npos
|
||||
(setf (svref nslots npos)
|
||||
(svref oslots opos))
|
||||
(progn (push name discarded)
|
||||
(unless (eq (svref oslots opos)
|
||||
*slot-unbound*)
|
||||
(setf (getf plist name)
|
||||
(svref oslots opos)))))))
|
||||
|
||||
;; Go through all the old shared slots.
|
||||
(iterate ((oclass-slot-and-val (list-elements oclass-slots)))
|
||||
(let ((name (car oclass-slot-and-val))
|
||||
(val (cdr oclass-slot-and-val)))
|
||||
(let ((npos (posq name nlayout)))
|
||||
(if npos
|
||||
(setf (svref nslots npos)
|
||||
(cdr oclass-slot-and-val))
|
||||
(progn (push name discarded)
|
||||
(unless (eq val *slot-unbound*)
|
||||
(setf (getf plist name)
|
||||
val)))))))
|
||||
|
||||
;; Go through all the new local slots to compute the added slots.
|
||||
(dolist (nlocal nlayout)
|
||||
(unless (or (memq nlocal olayout)
|
||||
(assq nlocal oclass-slots))
|
||||
(push nlocal added)))
|
||||
(without-interrupts (set-wrapper instance nwrapper)
|
||||
(set-slots instance nslots))
|
||||
(update-instance-for-redefined-class instance added discarded plist)
|
||||
nwrapper))
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
(defmacro change-class-internal (wrapper-fetcher slots-fetcher alloc)
|
||||
`(let* ((old-class (class-of instance))
|
||||
(copy (,alloc old-class))
|
||||
(guts (,alloc new-class))
|
||||
(new-wrapper (,wrapper-fetcher guts))
|
||||
(old-wrapper (class-wrapper old-class))
|
||||
(old-layout (wrapper-instance-slots-layout old-wrapper))
|
||||
(new-layout (wrapper-instance-slots-layout new-wrapper))
|
||||
(old-slots (,slots-fetcher instance))
|
||||
(new-slots (,slots-fetcher guts))
|
||||
(old-class-slots (wrapper-class-slots old-wrapper)))
|
||||
|
||||
;; "The values of local slots specified by both the class Cto and Cfrom are retained.
|
||||
;; If such a local slot was unbound, it remains unbound."
|
||||
(iterate ((new-slot (list-elements new-layout))
|
||||
(new-position (interval :from 0)))
|
||||
(let ((old-position (position new-slot old-layout :test #'eq)))
|
||||
(when old-position
|
||||
(setf (svref new-slots new-position)
|
||||
(svref old-slots old-position)))))
|
||||
|
||||
;; "The values of slots specified as shared in the class Cfrom and as local in the
|
||||
;; class Cto are retained."
|
||||
(iterate ((slot-and-val (list-elements old-class-slots)))
|
||||
(let ((position (position (car slot-and-val)
|
||||
new-layout :test #'eq)))
|
||||
(when position
|
||||
(setf (svref new-slots position)
|
||||
(cdr slot-and-val)))))
|
||||
|
||||
;; Make the copy point to the old instance's storage, and make the old instance point
|
||||
;; to the new storage.
|
||||
(without-interrupts (setf (,slots-fetcher copy)
|
||||
old-slots)
|
||||
(setf (,wrapper-fetcher instance)
|
||||
new-wrapper)
|
||||
(setf (,slots-fetcher instance)
|
||||
new-slots))
|
||||
(update-instance-for-different-class copy instance)
|
||||
instance))
|
||||
|
||||
(defmethod change-class ((instance standard-object)
|
||||
(new-class standard-class))
|
||||
(unless (std-instance-p instance)
|
||||
(error "Can't change the class of ~S to ~S~@
|
||||
because it isn't already an instance with metaclass~%~S." instance new-class
|
||||
'standard-class))
|
||||
(change-class-internal std-instance-wrapper std-instance-slots allocate-instance))
|
||||
|
||||
(defmethod change-class ((instance standard-object)
|
||||
(new-class funcallable-standard-class))
|
||||
(unless (fsc-instance-p instance)
|
||||
(error "Can't change the class of ~S to ~S~@
|
||||
because it isn't already an instance with metaclass~%~S." instance new-class
|
||||
'funcallable-standard-class))
|
||||
(change-class-internal fsc-instance-wrapper fsc-instance-slots allocate-instance))
|
||||
|
||||
(defmethod change-class ((instance t)
|
||||
(new-class-name symbol))
|
||||
(change-class instance (find-class new-class-name)))
|
||||
|
||||
|
||||
;;; The metaclass BUILT-IN-CLASS This metaclass is something of a weird creature. By this point,
|
||||
;;; all instances of it which will exist have been created, and no instance is ever created by
|
||||
;;; calling MAKE-INSTANCE. But, there are other parts of the protcol we must follow and those
|
||||
;;; definitions appear here.
|
||||
|
||||
|
||||
(defmethod shared-initialize :before ((class built-in-class)
|
||||
slot-names &rest initargs)
|
||||
(declare (ignore slot-names))
|
||||
(error "Attempt to initialize or reinitialize a built in class."))
|
||||
|
||||
(defmethod class-direct-slots ((class built-in-class))
|
||||
nil)
|
||||
|
||||
(defmethod class-slots ((class built-in-class))
|
||||
nil)
|
||||
|
||||
(defmethod class-direct-default-initargs ((class built-in-class))
|
||||
nil)
|
||||
|
||||
(defmethod class-default-initargs ((class built-in-class))
|
||||
nil)
|
||||
|
||||
(defmethod check-super-metaclass-compatibility ((c class)
|
||||
(s built-in-class))
|
||||
(or (eq s *the-class-t*)
|
||||
(error "~S cannot have ~S as a super.~%~
|
||||
The class ~S is the only built in class that can be a~%~
|
||||
superclass of a standard class." c s *the-class-t*)))
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
(defmethod check-super-metaclass-compatibility ((c std-class)
|
||||
(f forward-referenced-class))
|
||||
't)
|
||||
|
||||
|
||||
;;;
|
||||
|
||||
|
||||
(defmethod add-dependent ((metaobject dependent-update-mixin)
|
||||
dependent)
|
||||
(pushnew dependent (plist-value metaobject 'dependents)))
|
||||
|
||||
(defmethod remove-dependent ((metaobject dependent-update-mixin)
|
||||
dependent)
|
||||
(setf (plist-value metaobject 'dependents)
|
||||
(delete dependent (plist-value metaobject 'dependents))))
|
||||
|
||||
(defmethod map-dependents ((metaobject dependent-update-mixin)
|
||||
function)
|
||||
(dolist (dependent (plist-value metaobject 'dependents))
|
||||
(funcall function dependent)))
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,22 +0,0 @@
|
||||
boot
|
||||
braid
|
||||
cache
|
||||
combin
|
||||
compat
|
||||
construct
|
||||
cpl
|
||||
defcombin
|
||||
defs
|
||||
dlap
|
||||
env
|
||||
fixup
|
||||
fngen
|
||||
fsc
|
||||
lap
|
||||
methods
|
||||
plap
|
||||
precom2
|
||||
precom4
|
||||
test
|
||||
vector
|
||||
walk
|
||||
@@ -1,368 +0,0 @@
|
||||
;;;-*-Mode:LISP; Package:(CLOS LISP 1000); Base:10; Syntax:Common-lisp -*-
|
||||
;;;
|
||||
;;; *************************************************************************
|
||||
;;; Copyright (c) 1991 Venue
|
||||
;;; All rights reserved.
|
||||
;;; *************************************************************************
|
||||
;;;
|
||||
;;; Permutation vectors.
|
||||
;;;
|
||||
|
||||
(in-package 'clos)
|
||||
|
||||
(defmacro instance-slot-index (wrapper slot-name)
|
||||
`(let ((pos 0))
|
||||
(block loop
|
||||
(dolist (sn (wrapper-instance-slots-layout ,wrapper))
|
||||
(when (eq ,slot-name sn) (return-from loop pos))
|
||||
(incf pos)))))
|
||||
|
||||
|
||||
;;;
|
||||
;;;
|
||||
;;;
|
||||
(defmacro %isl-cache (isl) `(%svref ,isl 1))
|
||||
(defmacro %isl-field (isl) `(%svref ,isl 2))
|
||||
(defmacro %isl-mask (isl) `(%svref ,isl 3))
|
||||
(defmacro %isl-size (isl) `(%svref ,isl 4))
|
||||
(defmacro %isl-slot-name-lists (isl) `(%svref ,isl 5))
|
||||
|
||||
(defun make-isl (slot-name-lists)
|
||||
(multiple-value-bind (mask size)
|
||||
(compute-primary-pv-cache-size slot-name-lists)
|
||||
(make-isl-internal (wrapper-field 'number)
|
||||
(get-cache size)
|
||||
mask
|
||||
size
|
||||
slot-name-lists)))
|
||||
|
||||
(defun make-isl-internal (field cache mask size slot-name-lists)
|
||||
(let ((isl (make-array 6)))
|
||||
(setf (svref isl 0) 'isl
|
||||
(%isl-cache isl) cache
|
||||
(%isl-field isl) field
|
||||
(%isl-mask isl) mask
|
||||
(%isl-size isl) size
|
||||
(%isl-slot-name-lists isl) slot-name-lists)
|
||||
isl))
|
||||
|
||||
(defun make-isl-type-declaration (var)
|
||||
`(type simple-vector ,var))
|
||||
|
||||
(defun islp (x)
|
||||
(and (simple-vector-p x)
|
||||
(= (array-dimension x 0) 5)
|
||||
(eq (svref x 0) 'isl)))
|
||||
|
||||
(defvar *slot-name-lists-inner* (make-hash-table :test #'equal))
|
||||
(defvar *slot-name-lists-outer* (make-hash-table :test #'equal))
|
||||
|
||||
(defun intern-slot-name-lists (slot-name-lists)
|
||||
(flet ((inner (x)
|
||||
(or (gethash x *slot-name-lists-inner*)
|
||||
(setf (gethash x *slot-name-lists-inner*) (copy-list x))))
|
||||
(outer (x)
|
||||
(or (gethash x *slot-name-lists-outer*)
|
||||
(setf (gethash x *slot-name-lists-outer*) (make-isl (copy-list x))))))
|
||||
(outer (mapcar #'inner slot-name-lists))))
|
||||
|
||||
|
||||
|
||||
(defvar *pvs* (make-hash-table :test #'equal))
|
||||
|
||||
(defvar default-svuc-method nil)
|
||||
(defvar default-setf-svuc-method nil)
|
||||
|
||||
(defun optimize-slot-value-by-class-p (class slot-name setf-p)
|
||||
(or (not (eq *boot-state* 'complete))
|
||||
(let* ((slot-definition (find-slot-definition class slot-name))
|
||||
(gfun-name (if setf-p
|
||||
'(setf slot-value-using-class) 'slot-value-using-class))
|
||||
(gfun (gdefinition gfun-name))
|
||||
(csym (if setf-p 'default-setf-svuc-method 'default-svuc-method))
|
||||
(app-methods nil))
|
||||
(dolist (method (generic-function-methods gfun))
|
||||
(let* ((mspecs (method-specializers method))
|
||||
(specs (if setf-p (cdr mspecs) mspecs)))
|
||||
(when (and (specializer-applicable-p (first specs) class)
|
||||
(specializer-applicable-using-class-p (second specs) class)
|
||||
(specializer-applicable-p (third specs) slot-definition))
|
||||
(push method app-methods))))
|
||||
(and app-methods (null (cdr app-methods))
|
||||
(eq (car app-methods)
|
||||
(or (symbol-value csym)
|
||||
(let* ((specs (if setf-p
|
||||
'(t
|
||||
std-class
|
||||
standard-object
|
||||
standard-effective-slot-definition)
|
||||
'(std-class
|
||||
standard-object
|
||||
standard-effective-slot-definition)))
|
||||
(slist (mapcar #'find-class specs)))
|
||||
(set csym (get-method gfun nil slist)))))))))
|
||||
|
||||
(defun lookup-pv (isl args)
|
||||
(let* ((class-slot-p nil)
|
||||
(elements
|
||||
(gathering1 (collecting)
|
||||
(iterate ((slot-names (list-elements (%isl-slot-name-lists isl)))
|
||||
(arg (list-elements args)))
|
||||
(when slot-names
|
||||
(let* ((wrapper (check-wrapper-validity arg))
|
||||
(class (wrapper-class wrapper))
|
||||
(class-slots (wrapper-class-slots wrapper)))
|
||||
(dolist (slot-name slot-names)
|
||||
(if (and (optimize-slot-value-by-class-p
|
||||
class slot-name nil)
|
||||
(optimize-slot-value-by-class-p
|
||||
class slot-name t))
|
||||
(let ((index (instance-slot-index wrapper slot-name)))
|
||||
(if index
|
||||
(gather1 index)
|
||||
(let ((cell (assq slot-name class-slots)))
|
||||
(if cell
|
||||
(progn (setq class-slot-p t) (gather1 cell))
|
||||
(gather1 nil)))))
|
||||
(gather1 nil)))))))))
|
||||
(if class-slot-p ;Sure is a shame Common Lisp doesn't
|
||||
(make-permutation-vector elements) ;give me the right kind of hash table.
|
||||
(or (gethash elements *pvs*)
|
||||
(setf (gethash elements *pvs*) (make-permutation-vector elements))))))
|
||||
|
||||
(defun make-permutation-vector (indexes)
|
||||
(make-array (length indexes) :initial-contents indexes))
|
||||
|
||||
(defun make-pv-type-declaration (var)
|
||||
`(type simple-vector ,var))
|
||||
|
||||
(defmacro pvref (pv index)
|
||||
`(svref ,pv ,index))
|
||||
|
||||
|
||||
|
||||
(defun can-optimize-access (var required-parameters env)
|
||||
(let ((rebound? (caddr (variable-declaration 'variable-rebinding var env))))
|
||||
(if rebound?
|
||||
(car (memq rebound? required-parameters))
|
||||
(car (memq var required-parameters)))))
|
||||
|
||||
(defun optimize-slot-value (slots parameter form)
|
||||
(destructuring-bind (ignore ignore slot-name)
|
||||
form
|
||||
(optimize-instance-access slots :read parameter (eval slot-name) nil)))
|
||||
|
||||
(defun optimize-set-slot-value (slots parameter form)
|
||||
(destructuring-bind (ignore ignore slot-name new-value)
|
||||
form
|
||||
(optimize-instance-access slots :write parameter (eval slot-name) new-value)))
|
||||
|
||||
;;;
|
||||
;;; The <slots> argument is an alist, the CAR of each entry is the name of
|
||||
;;; a required parameter to the function. The alist is in order, so the
|
||||
;;; position of an entry in the alist corresponds to the argument's position
|
||||
;;; in the lambda list.
|
||||
;;;
|
||||
(defun optimize-instance-access (slots read/write parameter slot-name new-value)
|
||||
(let* ((parameter-entry (assq parameter slots))
|
||||
(slot-entry (assq slot-name (cdr parameter-entry)))
|
||||
(position (position parameter-entry slots)))
|
||||
(unless parameter-entry
|
||||
(error "Internal error in slot optimization."))
|
||||
(unless slot-entry
|
||||
(setq slot-entry (list slot-name))
|
||||
(push slot-entry (cdr parameter-entry)))
|
||||
(ecase read/write
|
||||
(:read
|
||||
(let ((form (list 'instance-read ''.PV-OFFSET. parameter position
|
||||
`',slot-name)))
|
||||
(push form (cdr slot-entry))
|
||||
form))
|
||||
(:write
|
||||
(let ((form (list 'instance-write ''.PV-OFFSET. parameter position
|
||||
`',slot-name '.new-value.)))
|
||||
(push form (cdr slot-entry))
|
||||
`(let ((.new-value. ,new-value)) ,form))))))
|
||||
|
||||
(define-walker-template instance-read)
|
||||
(define-walker-template instance-write)
|
||||
|
||||
|
||||
(defmacro instance-read (pv-offset parameter position slot-name)
|
||||
`(locally
|
||||
(declare (optimize (speed 3) (safety 0) (compilation-speed 0)))
|
||||
(let ((.INDEX. (pvref .PV. ,pv-offset)))
|
||||
(if (and (typep .INDEX. 'fixnum)
|
||||
(neq (setq .INDEX. (%svref ,(slot-vector-symbol position) .INDEX.))
|
||||
',*slot-unbound*))
|
||||
.INDEX.
|
||||
(pv-access-trap ,parameter .PV. ,pv-offset ,slot-name)))))
|
||||
|
||||
(defmacro instance-write (pv-offset parameter position slot-name new-value)
|
||||
`(locally
|
||||
(declare (optimize (speed 3) (safety 0) (compilation-speed 0)))
|
||||
(let ((.INDEX. (pvref .PV. ,pv-offset)))
|
||||
(if (typep .INDEX. 'fixnum)
|
||||
(setf (%svref ,(slot-vector-symbol position) .INDEX.) ,new-value)
|
||||
(pv-access-trap ,parameter .PV. ,pv-offset ,slot-name ,new-value)))))
|
||||
|
||||
(defun pv-access-trap (instance pv offset slot-name &optional (new-value nil nvp))
|
||||
;;
|
||||
;; First thing we do is a quick check to see if this is a class variable.
|
||||
;; This could be done inline by moving it to INSTANCE-READ/WRITE. I did
|
||||
;; not do that because I don't know whether its worth it.
|
||||
;;
|
||||
(let ((cell (pvref pv offset)))
|
||||
(if (consp cell)
|
||||
(if nvp (setf (cdr cell) new-value) (cdr cell))
|
||||
;;
|
||||
;; Well, now do a slow trap.
|
||||
;;
|
||||
(if nvp
|
||||
(setf (slot-value instance slot-name) new-value)
|
||||
(slot-value instance slot-name)))))
|
||||
|
||||
;;;
|
||||
;;; This magic function has quite a job to do indeed.
|
||||
;;;
|
||||
;;; The careful reader will recall that <slots> contains all of the optimized
|
||||
;;; slot access forms produced by OPTIMIZE-INSTANCE-ACCESS. Each of these is
|
||||
;;; a call to either INSTANCE-READ or INSTANCE-WRITE.
|
||||
;;;
|
||||
;;; At the time these calls were produced, the first argument was specified as
|
||||
;;; the symbol .PV-OFFSET.; what we have to do now is convert those pv-offset
|
||||
;;; arguments into the actual number that is the correct offset into the pv.
|
||||
;;;
|
||||
;;; But first, oh but first, we sort <slots> a bit so that for each argument
|
||||
;;; we have the slots in alphabetical order. This canonicalizes the ISL's a
|
||||
;;; bit and will hopefully lead to having fewer PV's floating around. Even
|
||||
;;; if the gain is only modest, it costs nothing.
|
||||
;;;
|
||||
(defun slot-name-lists-from-slots (slots)
|
||||
(mapcar #'(lambda (parameter-entry) (mapcar #'car (cdr parameter-entry)))
|
||||
(mutate-slots slots)))
|
||||
|
||||
(defun mutate-slots (slots)
|
||||
(let ((sorted (sort-slots slots))
|
||||
(pv-offset -1))
|
||||
(dolist (parameter-entry sorted)
|
||||
(dolist (slot-entry (cdr parameter-entry))
|
||||
(incf pv-offset)
|
||||
(dolist (form (cdr slot-entry))
|
||||
(setf (cadr form) pv-offset))))
|
||||
sorted))
|
||||
|
||||
(defun sort-slots (slots)
|
||||
(mapcar #'(lambda (parameter-entry)
|
||||
(cons (car parameter-entry)
|
||||
(sort (cdr parameter-entry) ;slot entries
|
||||
#'(lambda (a b)
|
||||
(string-lessp (symbol-name (car a))
|
||||
(symbol-name (car b)))))))
|
||||
slots))
|
||||
|
||||
|
||||
;;;
|
||||
;;; This needs to work in terms of metatypes and also needs to work for
|
||||
;;; automatically generated reader and writer functions.
|
||||
;;;
|
||||
(defun add-pv-binding (method-body plist required-parameters)
|
||||
(let* ((isl (getf plist :isl))
|
||||
(isl-cache-symbol (make-symbol "isl-cache")))
|
||||
(nconc plist (list :isl-cache-symbol isl-cache-symbol))
|
||||
(with-gathering ((slot-variables (collecting))
|
||||
(metatypes (collecting)))
|
||||
(iterate ((slots (list-elements isl))
|
||||
(i (interval :from 0)))
|
||||
(cond (slots
|
||||
(gather (slot-vector-symbol i) slot-variables)
|
||||
(gather 'standard-instance metatypes))
|
||||
(t
|
||||
(gather nil slot-variables)
|
||||
(gather t metatypes))))
|
||||
`((let ((.ISL. (locally (declare (special ,isl-cache-symbol)) ,isl-cache-symbol))
|
||||
(.PV. *empty-vector*)
|
||||
,@(remove nil slot-variables))
|
||||
(declare ,(make-isl-type-declaration '.ISL.)
|
||||
,(make-pv-type-declaration '.PV.))
|
||||
|
||||
(let* ((cache (%isl-cache .ISL.))
|
||||
(size (%isl-size .ISL.))
|
||||
(mask (%isl-mask .ISL.))
|
||||
(field (%isl-field .ISL.)))
|
||||
,(generating-lap-in-lisp '(cache size mask field)
|
||||
required-parameters
|
||||
(flatten-lap
|
||||
(emit-pv-dlap required-parameters metatypes slot-variables))))
|
||||
|
||||
,@method-body)))))
|
||||
|
||||
(defun emit-pv-dlap (required-parameters metatypes slot-variables)
|
||||
(let* ((slot-regs (mapcar #'(lambda (sv) (and sv (operand :lisp-variable sv)))
|
||||
slot-variables))
|
||||
(wrappers (dlap-wrappers metatypes))
|
||||
(nwrappers (remove nil wrappers)))
|
||||
(flet ((wrapper-moves (miss-label)
|
||||
(dlap-wrapper-moves wrappers required-parameters metatypes miss-label slot-regs)))
|
||||
(prog1 (emit-dlap-internal
|
||||
nwrappers ;wrapper-regs
|
||||
(wrapper-moves 'pv-miss) ;wrapper-moves
|
||||
(opcode :exit-lap-in-lisp) ;hit
|
||||
(flatten-lap ;miss
|
||||
(opcode :label 'pv-miss)
|
||||
(opcode :move
|
||||
(operand :lisp `(primary-pv-cache-miss
|
||||
.ISL. ,@required-parameters))
|
||||
(operand :lisp-variable '.PV.))
|
||||
(apply #'flatten-lap (wrapper-moves 'pv-wrapper-miss)) ; -- Maybe the wrappers have changed.
|
||||
(opcode :label 'pv-wrapper-miss)
|
||||
(opcode :exit-lap-in-lisp))
|
||||
'pv-miss ;miss-label
|
||||
(operand :lisp-variable '.PV.)) ;value-reg
|
||||
(mapc #'deallocate-register nwrappers)))))
|
||||
|
||||
(defun compute-primary-pv-cache-size (slot-name-lists)
|
||||
(compute-cache-parameters (- (length slot-name-lists) (count nil slot-name-lists))
|
||||
t
|
||||
2))
|
||||
|
||||
(defun pv-cache-limit-fn (nlines)
|
||||
(default-limit-fn nlines))
|
||||
|
||||
(defun primary-pv-cache-miss (isl &rest args)
|
||||
(let* ((wrappers
|
||||
(gathering1 (collecting)
|
||||
(iterate ((slot-names (list-elements (%isl-slot-name-lists isl)))
|
||||
(arg (list-elements args)))
|
||||
(when slot-names (gather1 (check-wrapper-validity arg))))))
|
||||
(pv (lookup-pv isl args))
|
||||
(field (%isl-field isl))
|
||||
(cache (%isl-cache isl))
|
||||
(nkeys (length wrappers)))
|
||||
(multiple-value-bind (new-field new-cache new-mask new-size)
|
||||
(fill-cache field cache nkeys t #'pv-cache-limit-fn
|
||||
(if (= nkeys 1) (car wrappers) wrappers)
|
||||
pv)
|
||||
(when (or (not (= new-field field))
|
||||
(not (eq new-cache cache)))
|
||||
(without-interrupts ;NOTE:
|
||||
(setf (%isl-field isl) new-field ; There is no mechanism to
|
||||
(%isl-cache isl) new-cache ; synchronize the reading of
|
||||
(%isl-size isl) new-size ; these values. But, this is
|
||||
(%isl-mask isl) new-mask)) ; a safe order to write them
|
||||
; in. Stricly speaking, the
|
||||
; use of without-interrupts
|
||||
; is superfluous.
|
||||
(when (neq new-cache cache) (free-cache cache))))
|
||||
pv))
|
||||
|
||||
|
||||
|
||||
(defmethod wrapper-fetcher ((class standard-class))
|
||||
'std-instance-wrapper)
|
||||
|
||||
(defmethod slots-fetcher ((class standard-class))
|
||||
'std-instance-slots)
|
||||
|
||||
(defmethod raw-instance-allocator ((class standard-class))
|
||||
'%%allocate-instance--class)
|
||||
File diff suppressed because it is too large
Load Diff
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Binary file not shown.
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user