github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-01-13 15:37:38 +00:00
Code Issues Projects Releases Wiki Activity

Migration from Interlisp to CL format (#591)

Browse Source 
Tool for translating File Manager format files to Common Lisp format
This commit is contained in:
Arun Welch 2021-11-28 23:07:37 -07:00 committed by GitHub
parent b303e0affa
commit 3d8066b7e8
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
20 changed files with 4961 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
lispusers/MIGRATION/DIR.TXT Normal file
View File

@ -0,0 +1,3 @@
Contains a tool for translating File Manger format Interlisp source
files from Medley into Common Lisp text files. The software runs in
the Medley system.

116
lispusers/MIGRATION/FILEPKGRECORDS Normal file
View File

@ -0,0 +1,116 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(* "
Copyright (c) 1982, 1983, 1984, 1985, 1986, 1987, 1988 by Xerox Corporation. All rights reserved.
The following program was created in 1982 but has not been published
within the meaning of the copyright law, is furnished under license,
and may not be used, copied and/or disclosed except in accordance
with the terms of said license.
")
(PRETTYCOMPRINT FILEPKGRECORDSCOMS)
(RPAQQ FILEPKGRECORDSCOMS
[(COMS (* ;
 "standard records for accessing file package type/command parts. Exported for PRETTY")
(RECORDS * FILEPKGRECORDS)])
(RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP))
(ACCESSFNS FILEPKGCOM [[ADD (GETPROP DATUM 'ADDTOPRETTYCOM)
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM 'ADDTOPRETTYCOM NEWVALUE))
(T (/REMPROP DATUM 'ADDTOPRETTYCOM]
[DELETE (GETPROP DATUM 'DELFROMPRETTYCOM)
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM 'DELFROMPRETTYCOM NEWVALUE))
(T (/REMPROP DATUM 'DELFROMPRETTYCOM]
[PRETTYTYPE (GETPROP DATUM 'PRETTYTYPE)
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM 'PRETTYTYPE NEWVALUE))
(T (/REMPROP DATUM 'PRETTYTYPE]
[CONTENTS (GETPROP DATUM 'FILEPKGCONTENTS)
(UNDOABLE (COND
(NEWVALUE (/PUTPROP DATUM 'FILEPKGCONTENTS NEWVALUE))
(T (/REMPROP DATUM 'FILEPKGCONTENTS]
(MACRO [CDR (FASSOC DATUM (GETTOPVAL 'PRETTYDEFMACROS]
(STANDARD [COND
[NEWVALUE (PUTASSOC DATUM NEWVALUE
(OR (LISTP (GETTOPVAL
'PRETTYDEFMACROS))
(SETTOPVAL 'PRETTYDEFMACROS
(LIST (LIST DATUM]
(T (SETTOPVAL 'PRETTYDEFMACROS
(REMOVE (FASSOC DATUM (GETTOPVAL
'PRETTYDEFMACROS))
(GETTOPVAL 'PRETTYDEFMACROS]
UNDOABLE
(COND
[NEWVALUE (/PUTASSOC DATUM NEWVALUE
(OR (LISTP (GETTOPVAL 'PRETTYDEFMACROS))
(/SETTOPVAL 'PRETTYDEFMACROS
(LIST (LIST DATUM]
(T (/SETTOPVAL 'PRETTYDEFMACROS
(REMOVE (FASSOC DATUM (GETTOPVAL
'PRETTYDEFMACROS))
(GETTOPVAL 'PRETTYDEFMACROS]
(* Not an atom record cause want
 REMPROP on NILs.)
(* NOTE%: PRETTCOM on PRETTY has
 open-coded access to the MACRO
 property.)
(INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE
FILEPKGCONTENTS)))
(ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED
HASDEF EDITDEF FILEGETDEF CANFILEDEF)
(ACCESSFNS FILEPKGTYPE [(CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM))
(CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))
)
(CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST
DATUM)))
(STANDARD (SETTOPVAL (CAR (
SEARCHPRETTYTYPELST
DATUM NEWVALUE)
)
NEWVALUE)
UNDOABLE
(/SETTOPVAL (CAR (
SEARCHPRETTYTYPELST
DATUM NEWVALUE))
NEWVALUE)))
(DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST
DATUM)))
(CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST
DATUM NEWVALUE))
NEWVALUE)))
(ALLFIELDS NIL (/SETTOPVAL
'PRETTYTYPELST
(REMOVE (SEARCHPRETTYTYPELST
DATUM)
(GETTOPVAL 'PRETTYTYPELST]
(* NOTE%: PRETTYCOM on PRETTY has
 open-coded access to GETDEF property)
(INIT [PROGN (SETQ SYSPROPS (UNION FILEPKGTYPEPROPS SYSPROPS))
(MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X)
(PUT X
'PROPTYPE
'FILEPKGCOMS]
(ADDTOVAR PRETTYTYPELST))))
(ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP)
[ACCESSFNS FILE ((FILEPROP (GETPROP DATUM 'FILE)
(STANDARD (PUTPROP DATUM 'FILE NEWVALUE)
UNDOABLE
(/PUTPROP DATUM 'FILE NEWVALUE])
(RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME))
(RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED))
IL:STOP

1
lispusers/MIGRATION/FILEPKGRECORDS.LCOM Normal file
View File

@ -0,0 +1 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Jan-93 19:53:16" ("compiled on " {DSK}<usr>local>src>tape>MIGRATION>FILEPKGRECORDS.;1 ) "11-Jul-91 21:52:09" bcompl'd in "Lispcore 11-Jul-91 ..." dated "11-Jul-91 21:57:45") (PRETTYCOMPRINT FILEPKGRECORDSCOMS) (RPAQQ FILEPKGRECORDSCOMS ((COMS (* ; "standard records for accessing file package type/command parts. Exported for PRETTY") (RECORDS * FILEPKGRECORDS)))) (RPAQQ FILEPKGRECORDS (FILEPKGCOM FILEPKGTYPE FILE FILEDATEPAIR FILEPROP)) (ACCESSFNS FILEPKGCOM ((ADD (GETPROP DATUM (QUOTE ADDTOPRETTYCOM)) (UNDOABLE (COND (NEWVALUE (/PUTPROP DATUM (QUOTE ADDTOPRETTYCOM) NEWVALUE)) (T (/REMPROP DATUM (QUOTE ADDTOPRETTYCOM)))))) (DELETE ( GETPROP DATUM (QUOTE DELFROMPRETTYCOM)) (UNDOABLE (COND (NEWVALUE (/PUTPROP DATUM (QUOTE DELFROMPRETTYCOM) NEWVALUE)) (T (/REMPROP DATUM (QUOTE DELFROMPRETTYCOM)))))) (PRETTYTYPE (GETPROP DATUM (QUOTE PRETTYTYPE)) (UNDOABLE (COND (NEWVALUE (/PUTPROP DATUM (QUOTE PRETTYTYPE) NEWVALUE)) (T ( /REMPROP DATUM (QUOTE PRETTYTYPE)))))) (CONTENTS (GETPROP DATUM (QUOTE FILEPKGCONTENTS)) (UNDOABLE ( COND (NEWVALUE (/PUTPROP DATUM (QUOTE FILEPKGCONTENTS) NEWVALUE)) (T (/REMPROP DATUM (QUOTE FILEPKGCONTENTS)))))) (MACRO (CDR (FASSOC DATUM (GETTOPVAL (QUOTE PRETTYDEFMACROS)))) (STANDARD (COND (NEWVALUE (PUTASSOC DATUM NEWVALUE (OR (LISTP (GETTOPVAL (QUOTE PRETTYDEFMACROS))) (SETTOPVAL (QUOTE PRETTYDEFMACROS) (LIST (LIST DATUM)))))) (T (SETTOPVAL (QUOTE PRETTYDEFMACROS) (REMOVE (FASSOC DATUM ( GETTOPVAL (QUOTE PRETTYDEFMACROS))) (GETTOPVAL (QUOTE PRETTYDEFMACROS)))))) UNDOABLE (COND (NEWVALUE ( /PUTASSOC DATUM NEWVALUE (OR (LISTP (GETTOPVAL (QUOTE PRETTYDEFMACROS))) (/SETTOPVAL (QUOTE PRETTYDEFMACROS) (LIST (LIST DATUM)))))) (T (/SETTOPVAL (QUOTE PRETTYDEFMACROS) (REMOVE (FASSOC DATUM (GETTOPVAL (QUOTE PRETTYDEFMACROS))) (GETTOPVAL (QUOTE PRETTYDEFMACROS))))))))) (* Not an atom record cause want REMPROP on NILs.) (* NOTE%: PRETTCOM on PRETTY has open-coded access to the MACRO property. ) (INIT (FILEPKGCOMPROPS ADDTOPRETTYCOM DELFROMPRETTYCOM PRETTYTYPE FILEPKGCONTENTS))) (ATOMRECORD FILEPKGTYPE (NEWCOM WHENFILED WHENUNFILED GETDEF NULLDEF DELDEF PUTDEF WHENCHANGED HASDEF EDITDEF FILEGETDEF CANFILEDEF) (ACCESSFNS FILEPKGTYPE ((CHANGEDLST (CAR (SEARCHPRETTYTYPELST DATUM)) ( CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE))) (CHANGED (GETTOPVAL (CAR (SEARCHPRETTYTYPELST DATUM))) ( STANDARD (SETTOPVAL (CAR (SEARCHPRETTYTYPELST DATUM NEWVALUE)) NEWVALUE) UNDOABLE (/SETTOPVAL (CAR ( SEARCHPRETTYTYPELST DATUM NEWVALUE)) NEWVALUE))) (DESCRIPTION (CAR (CDDR (SEARCHPRETTYTYPELST DATUM))) (CAR (RPLACA (CDDR (SEARCHPRETTYTYPELST DATUM NEWVALUE)) NEWVALUE))) (ALLFIELDS NIL (/SETTOPVAL ( QUOTE PRETTYTYPELST) (REMOVE (SEARCHPRETTYTYPELST DATUM) (GETTOPVAL (QUOTE PRETTYTYPELST)))))) (* NOTE%: PRETTYCOM on PRETTY has open-coded access to GETDEF property) (INIT (PROGN (SETQ SYSPROPS ( UNION FILEPKGTYPEPROPS SYSPROPS)) (MAPC FILEPKGTYPEPROPS (FUNCTION (LAMBDA (X) (PUT X (QUOTE PROPTYPE) (QUOTE FILEPKGCOMS)))))) (ADDTOVAR PRETTYTYPELST)))) (ATOMRECORD FILE (FILECHANGES FILEDATES FILEMAP) (ACCESSFNS FILE ((FILEPROP (GETPROP DATUM (QUOTE FILE )) (STANDARD (PUTPROP DATUM (QUOTE FILE) NEWVALUE) UNDOABLE (/PUTPROP DATUM (QUOTE FILE) NEWVALUE))))) ) (RECORD FILEDATEPAIR (FILEDATE . DATEFILENAME)) (RECORD FILEPROP ((COMSNAME . LOADTYPE) . TOBEDUMPED)) NIL

805
lispusers/MIGRATION/IL-CONVERT Normal file
View File

@ -0,0 +1,805 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "IL-CONVERT" BASE 10)
(IL:FILECREATED "26-Jan-90 10:28:55" IL:|{DSK}/users/welch/migration/IL-CONVERT.;5| 30652
IL:|changes| IL:|to:| (IL:VARS IL:IL-CONVERTCOMS)
IL:|previous| IL:|date:| "25-Jan-90 14:45:43" IL:|{DSK}/users/welch/migration/IL-CONVERT.;4|)
; Copyright (c) 1989, 1990 by ENVOS Corporation. All rights reserved.
(IL:PRETTYCOMPRINT IL:IL-CONVERTCOMS)
(IL:RPAQQ IL:IL-CONVERTCOMS
((IL:FUNCTIONS IL-DEFCONV)
(IL:* IL:|;;|
 "Used when an Interlisp function is the same as the Common Lisp function of the same name.")
(IL:FUNCTIONS IL-COPYDEF)
(IL:* IL:|;;| "Used to define a run-time function (not a converter function).")
(IL:FUNCTIONS IL-DEFUN IL-DEFVAR)
(IL:* IL:|;;| "
; Creates an external symbol in the IL package.
(defmacro il-defsym (name)
`(export (intern (symbol-name ',name) *il-package*) *il-package*))
(defmacro il-import (symbol)
`(progn (import ,symbol 'il)
(export (find-symbol (symbol-name ,symbol) 'il) 'il)))
")
(IL:FUNCTIONS IL-COPYCONV)
(IL:* IL:|;;| "Defines a \"Non-conversion\" form for use with things like \\GETBASE.")
(IL:FUNCTIONS IL-WARNINGFORM)
(IL:* IL:|;;| "Defines a function (e.g. PROGN-IF-NEEDED) that takes a list and sticks a PROGN (or whatever) at the beginning if the length is not 1. Used to eliminate ugly redundant PROGNs. If the length is 0, returns whatever the form itself returns when given no arguments (e.g. T for AND, NIL for OR).")
(IL:P
(MACROLET ((DEF-*-IF-NEEDED
(NAME)
(LET ((NAME-STRING (SYMBOL-NAME NAME)))
`(DEFUN ,(INTERN (CONCATENATE 'STRING NAME-STRING "-IF-NEEDED"))
(ARGS)
(CASE (LENGTH ARGS)
(0 ,(EVAL `(,NAME)))
(1 (FIRST ARGS))
(T `(,',NAME ,@ARGS)))))))
(DEF-*-IF-NEEDED PROGN)
(DEF-*-IF-NEEDED AND)
(DEF-*-IF-NEEDED OR)))
(IL:STRUCTURES FAKE-SYMBOL SHARP-DOT SHARP-COMMA)
(IL:* IL:|;;| "Aux function to see whether or not to generate a symbolp check")
(IL:FUNCTIONS QUOTED-SYMBOL-P)
(IL:VARIABLES *ORIGINAL-READTABLE*)
(IL:FUNCTIONS OLD-CONVERT-FILE)
(IL:P (EXPORT 'CONVERT-FILE))
(IL:* IL:|;;| "(convert-file \"~/medley/ADISPLAY\" \"adisplay\") (convert-file \"foo1\" \"foo2\") (convert-file \"foo3\" \"foo4\")")
(IL:P (EXPORT '(READ-EXPORTS WRITE-EXPORTS READ-RECORD-TYPES WRITE-RECORD-TYPES)))
(IL:FUNCTIONS READ-EXPORTS)
(IL:* IL:\; "Get the symbol list")
(IL:FUNCTIONS WRITE-EXPORTS READ-RECORD-TYPES WRITE-RECORD-TYPES READ-HASH-TABLE
WRITE-HASH-TABLE)
(IL:FUNCTIONS CONVERT-FILE CONVERT-FILECOMS CONVERT-ONE-FILECOM
EXPURGATE-EXTRANEOUS-PROGNS REORDER-FILECOMS MAKE-EXPORT-FORM)
(IL:VARIABLES *WALKER-TEMPLATES*)
(IL:FUNCTIONS GET-WALKER-TEMPLATE WALK-FORM-INTERNAL WALK-TEMPLATE
WALK-TEMPLATE-HANDLE-REPEAT WALK-TEMPLATE-HANDLE-REPEAT-1 WALK-REPEAT-EVAL RECONS
RELIST RELIST* RELIST-INTERNAL)
(IL:VARIABLES *GETVALUE-TRANSLATION* *CURRENT-DEFINITION* *CURRENT-DEFINITION-TYPE*
*CURRENT-EXPRESSION* *CURRENT-LOCALS* *FILE-CONTEXT* *WALKER-FIND-PARAMETER-LIST*
*WARNINGS-MADE* *PACKAGE-FOR-IL-SYMBOLS* *PACKAGE-FOR-RESULT-FILE*
*PARAMETERS-ALWAYS-OPTIONAL* *PROMPT-FOR-UNKNOWN-MACRO-TEMPLATE*
*UNKNOWN-MACRO-ACTION* *ALWAYS-INCLUDE-PROPS*)
(IL:DECLARE\: IL:DONTCOPY (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE)
IL:IL-CONVERT))))
(XCL:DEFDEFINER IL-DEFCONV IL:FUNCTIONS (NAME ARGLIST &REST REST)
(CHECK-TYPE NAME SYMBOL)
(LET ((FN-NAME (FIND-SYMBOL (SYMBOL-NAME NAME)
*IL-PACKAGE*)))
(IF FN-NAME
`(SETF (GET ',FN-NAME 'CONVERT-FORM)
#'(LAMBDA ,ARGLIST ,@REST))
(PROGN (WARN "No symbol ~:@(~a~) found in IL package." NAME)
NIL))))
(IL:* IL:|;;|
"Used when an Interlisp function is the same as the Common Lisp function of the same name.")
(DEFMACRO IL-COPYDEF (NAME &OPTIONAL (NEWNAME NAME))
(LET ((SYM (FIND-SYMBOL (SYMBOL-NAME NEWNAME)
*IL-PACKAGE*)))
(UNLESS SYM (ERROR "No symbol ~:@(~a~) found in IL package." SYM))
`(SETF (GET ',SYM 'CONVERT-FORM)
#'(LAMBDA (&REST ARGS)
(CONS ',NAME (MAPCONVERT ARGS))))))
(IL:* IL:|;;| "Used to define a run-time function (not a converter function).")
(XCL:DEFDEFINER IL-DEFUN IL:FUNCTIONS (NAME &REST REST)
(CHECK-TYPE NAME SYMBOL)
(LET* ((NAME-STRING (SYMBOL-NAME NAME))
(IL-SYM (INTERN NAME-STRING 'IL))
(IL-SYM1 (IF (CHAR/= (ELT NAME-STRING 0)
#\/)
(INTERN (CONCATENATE 'STRING "/" NAME-STRING)
'IL))))
`(PROGN (EXPORT ',IL-SYM 'IL)
(DEFUN ,IL-SYM ,@REST) (IL:* IL:\;
 "Also make a version starting with a /")
,@(IF IL-SYM1
`((EXPORT ',IL-SYM1 'IL)
(SETF (SYMBOL-FUNCTION ',IL-SYM1)
(SYMBOL-FUNCTION ',IL-SYM)))))))
(XCL:DEFDEFINER IL-DEFVAR IL:FUNCTIONS (NAME &REST ARGS)
(LET ((IL-SYM (INTERN (SYMBOL-NAME NAME)
*IL-PACKAGE*)))
`(PROGN (EXPORT ',IL-SYM 'IL)
(DEFVAR ,IL-SYM ,@(MAPCONVERT ARGS)))))
(IL:* IL:|;;|
"
; Creates an external symbol in the IL package.
(defmacro il-defsym (name)
`(export (intern (symbol-name ',name) *il-package*) *il-package*))
(defmacro il-import (symbol)
`(progn (import ,symbol 'il)
(export (find-symbol (symbol-name ,symbol) 'il) 'il)))
")
(DEFMACRO IL-COPYCONV (OLDNAME NEWNAME)
(LET* ((OLD-SYM (FIND-SYMBOL (SYMBOL-NAME OLDNAME)
*IL-PACKAGE*))
(NEW-SYM (FIND-SYMBOL (SYMBOL-NAME NEWNAME)
*IL-PACKAGE*)))
(UNLESS OLD-SYM (ERROR "No symbol ~:@(~a~) found in IL package." OLD-SYM))
(UNLESS NEW-SYM (ERROR "No symbol ~:@(~a~) found in IL package." NEW-SYM))
`(SETF (GET ',NEW-SYM 'CONVERT-FORM)
#'(LAMBDA (&REST ARGS)
(APPLY (GET ',OLD-SYM 'CONVERT-FORM)
ARGS)))))
(IL:* IL:|;;| "Defines a \"Non-conversion\" form for use with things like \\GETBASE.")
(XCL:DEFDEFINER IL-WARNINGFORM IL:FUNCTIONS (NAME &OPTIONAL (TEMPLATE '(NIL REPEAT (EVAL)))
(WARN-SWITCH '*WARN-ON-UNTRANSLATABLE-IL-FORM*)
)
(LET ((FN-NAME (FIND-SYMBOL (SYMBOL-NAME NAME)
*IL-PACKAGE*)))
(IF FN-NAME
`(SETF (GET ',FN-NAME 'CONVERT-FORM)
#'(LAMBDA (&REST REST)
(DECLARE (SPECIAL ,WARN-SWITCH))
(WHEN ,WARN-SWITCH
(WARN "Unable to translate a ~a form." ',FN-NAME))
(WALK-TEMPLATE (CONS ',FN-NAME REST)
',TEMPLATE)))
(PROGN (WARN "No symbol ~:@(~a~) found in IL package." NAME)
NIL))))
(IL:* IL:|;;|
"Defines a function (e.g. PROGN-IF-NEEDED) that takes a list and sticks a PROGN (or whatever) at the beginning if the length is not 1. Used to eliminate ugly redundant PROGNs. If the length is 0, returns whatever the form itself returns when given no arguments (e.g. T for AND, NIL for OR)."
)
(MACROLET ((DEF-*-IF-NEEDED (NAME)
(LET ((NAME-STRING (SYMBOL-NAME NAME)))
`(DEFUN ,(INTERN (CONCATENATE 'STRING NAME-STRING "-IF-NEEDED")) (ARGS)
(CASE (LENGTH ARGS)
(0 ,(EVAL `(,NAME)))
(1 (FIRST ARGS))
(T `(,',NAME ,@ARGS)))))))
(DEF-*-IF-NEEDED PROGN)
(DEF-*-IF-NEEDED AND)
(DEF-*-IF-NEEDED OR))
(DEFSTRUCT (FAKE-SYMBOL (:CONSTRUCTOR MAKE-FAKE-SYMBOL (NAME))
(:PRINT-FUNCTION (LAMBDA (OBJ STREAM DEPTH)
(PRINC (FAKE-SYMBOL-NAME OBJ)
STREAM))))
NAME)
(DEFSTRUCT (SHARP-DOT (:PRINT-FUNCTION (LAMBDA (SELF STREAM DEPTH)
(WRITE-STRING "#." STREAM)
(WRITE (SHARP-DOT-CONTENTS SELF)
:STREAM STREAM))))
CONTENTS)
(DEFSTRUCT (SHARP-COMMA (:PRINT-FUNCTION (LAMBDA (SELF STREAM DEPTH)
(WRITE-STRING "#," STREAM)
(WRITE (SHARP-COMMA-CONTENTS SELF)
:STREAM STREAM))))
CONTENTS)
(IL:* IL:|;;| "Aux function to see whether or not to generate a symbolp check")
(DEFUN QUOTED-SYMBOL-P (X)
(AND (CONSP X)
(EQ (CAR X)
'QUOTE)
(SYMBOLP (CADR X))
(NULL (CDDR X))))
(DEFVAR *ORIGINAL-READTABLE* (COPY-READTABLE NIL))
(DEFUN OLD-CONVERT-FILE (INFILE OUTFILE)
(WITH-OPEN-FILE (INSTREAM INFILE)
(IF OUTFILE
(WITH-OPEN-STREAM (OUTSTREAM (COND
((EQ OUTFILE 'T)
(MAKE-BROADCAST-STREAM *STANDARD-OUTPUT*))
(T (OPEN OUTFILE :DIRECTION :OUTPUT :IF-EXISTS
:SUPERSEDE :IF-DOES-NOT-EXIST :CREATE))))
(CONVERT-FILE-INTERNAL INSTREAM OUTSTREAM))
(CONVERT-FILE-INTERNAL INSTREAM NIL))))
(EXPORT 'CONVERT-FILE)
(IL:* IL:|;;|
"(convert-file \"~/medley/ADISPLAY\" \"adisplay\") (convert-file \"foo1\" \"foo2\") (convert-file \"foo3\" \"foo4\")"
)
(EXPORT '(READ-EXPORTS WRITE-EXPORTS READ-RECORD-TYPES WRITE-RECORD-TYPES))
(DEFUN READ-EXPORTS (FILE)
(IL:* IL:|;;| "Read the exported-symbols file if it exists")
(WITH-OPEN-FILE (STREAM FILE :IF-DOES-NOT-EXIST NIL)
(WHEN STREAM
(READ STREAM) (IL:* IL:\;
 "Read the \"(in-package)\" form")
(SETQ *EXPORTED-IL-SYMBOLS* (CADADR (READ STREAM))))))
(IL:* IL:\; "Get the symbol list")
(DEFUN WRITE-EXPORTS (FILE)
(WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE :IF-DOES-NOT-EXIST :CREATE)
(SETQ *EXPORTED-IL-SYMBOLS* (SORT *EXPORTED-IL-SYMBOLS* #'STRING< :KEY #'SYMBOL-NAME))
(LET ((*PACKAGE* *IL-PACKAGE*))
(FORMAT STREAM "(lisp:in-package \"IL\")~%(lisp:export '(")
(DOLIST (SYM *EXPORTED-IL-SYMBOLS*)
(FORMAT STREAM "~% ~s" SYM))
(FORMAT STREAM ")~%"))))
(DEFUN READ-RECORD-TYPES (FILE) (IL:* IL:\;
 "Read the record-types file if it exists")
(WITH-OPEN-FILE (STREAM FILE :IF-DOES-NOT-EXIST NIL)
(WHEN STREAM (READ-HASH-TABLE *RECORD-TYPES* STREAM))))
(DEFUN WRITE-RECORD-TYPES (FILE)
(WITH-OPEN-FILE (STREAM FILE :DIRECTION :OUTPUT :IF-EXISTS :SUPERSEDE :IF-DOES-NOT-EXIST :CREATE)
(WRITE-HASH-TABLE *RECORD-TYPES* STREAM)
(TERPRI STREAM)))
(DEFUN READ-HASH-TABLE (HT STREAM &AUX ITEM)
(LOOP (WHEN (EQ (SETQ ITEM (READ STREAM NIL 'STOP))
'STOP)
(RETURN))
(SETF (GETHASH (CAR ITEM)
HT)
(CDR ITEM))))
(DEFUN WRITE-HASH-TABLE (HT STREAM)
(LET* ((COUNT (HASH-TABLE-COUNT HT))
(SORTED-TABLE (MAKE-ARRAY COUNT))
(I 0))
(MAPHASH #'(LAMBDA (KEY VALUE)
(SETF (SVREF SORTED-TABLE I)
(CONS KEY VALUE))
(INCF I))
HT)
(SORT SORTED-TABLE #'STRING< :KEY #'(LAMBDA (X)
(SYMBOL-NAME (CAR X))))
(DOTIMES (I COUNT)
(PPRINT (SVREF SORTED-TABLE I)
STREAM))))
(DEFUN CONVERT-FILE (FILENAME OUTFILE)
(LET* ((REAL-FILENAME (FIND-SYMBOL (STRING FILENAME)
(FIND-PACKAGE 'IL)))
(COMS (SYMBOL-VALUE (OR (CAAR (GET REAL-FILENAME 'IL:FILE))
(ERROR "~a has no FILES definition." FILENAME)))))
(IF OUTFILE
(WITH-OPEN-STREAM (OUTSTREAM (COND
((EQ OUTFILE 'T)
(MAKE-BROADCAST-STREAM *STANDARD-OUTPUT*))
(T (OPEN OUTFILE :DIRECTION :OUTPUT :IF-EXISTS
:SUPERSEDE :IF-DOES-NOT-EXIST :CREATE))))
(CONVERT-FILECOMS COMS REAL-FILENAME OUTSTREAM))
(CONVERT-FILECOMS COMS REAL-FILENAME NIL))))
(DEFUN CONVERT-FILECOMS (COMS FILENAME &OPTIONAL OUTSTREAM)
(LET ((*EXPORTED-IL-SYMBOLS* NIL)
REORDERED-FILECOMS CONVERTED-FILE-LIST)
(FORMAT T "~&Processing Forms...~%")
(SETQ REORDERED-FILECOMS (REORDER-FILECOMS COMS)
CONVERTED-FILE-LIST
(EXPURGATE-EXTRANEOUS-PROGNS (MAPCAR 'CONVERT-ONE-FILECOM REORDERED-FILECOMS)))
(WHEN OUTSTREAM
(FORMAT T "~&Writing output...")
(LET* ((MFE (GET FILENAME 'IL:MAKEFILE-ENVIRONMENT))
(*PACKAGE* (OR (FIND-PACKAGE (EVAL (GETF MFE :PACKAGE)))
*IL-PACKAGE*))
(*PRINT-PRETTY* T)
(*PRINT-CASE* :DOWNCASE))
(WHEN MFE
(PRINT '(IN-PACKAGE "INTERLISP" :USE NIL :NICKNAMES '("IL"))
OUTSTREAM))
(PRINT (IF MFE
(LIST 'IN-PACKAGE (GETF MFE ':PACKAGE))
'(IN-PACKAGE "INTERLISP" :USE NIL :NICKNAMES '("IL")))
OUTSTREAM)
(TERPRI OUTSTREAM)
(WHEN *EXPORTED-IL-SYMBOLS*
(PRINT (MAKE-EXPORT-FORM *EXPORTED-IL-SYMBOLS*)
OUTSTREAM)
(TERPRI OUTSTREAM))
(DOLIST (FORM CONVERTED-FILE-LIST)
(WHEN FORM
(PRINT FORM OUTSTREAM)
(TERPRI OUTSTREAM)))))))
(DEFUN CONVERT-ONE-FILECOM (COM)
(UNLESS (CONSP COM)
(ERROR "Invalid filecom: ~s" COM))
(LET (
(IL:* IL:|;;| "We bind these for the warnings mechanism in case the filecom type is unknown... They'll be rebound lower down.")
(*CURRENT-EXPRESSION* COM)
(*CURRENT-DEFINITION* (CAR COM))
(*CURRENT-DEFINITION-TYPE* "Filecom")
(*WARNINGS-MADE* NIL)
(CONVERTER (GET (CAR COM)
'CONVERT-COM))
(IL:* IL:|;;| "FILEVARS are handled at this level, except in PROP and IFPROP coms.")
(FILEVAR-P (AND (EQ (SECOND COM)
'IL:*)
(NOT (MEMBER (FIRST COM)
' (IL:* IL:PROP IL:IFPROP))))))
(FUNCALL (OR CONVERTER 'CONVERT-UNKNOWN-COM)
(IF CONVERTER
(IF FILEVAR-P
(IL:EVAL (THIRD COM))
(CDR COM))
COM))))
(DEFUN EXPURGATE-EXTRANEOUS-PROGNS (FORMS-LIST)
(LET (RESULT)
(DOLIST (FORM FORMS-LIST)
(SETQ RESULT (NCONC RESULT (IF (AND (CONSP FORM)
(EQ (CAR FORM)
'PROGN))
(EXPURGATE-EXTRANEOUS-PROGNS (CDR FORM))
(CONS FORM NIL)))))
RESULT))
(DEFUN REORDER-FILECOMS (COMS-LIST)
(LET (EARLY-LIST LATE-LIST)
(LABELS ((EARLY-P (COM)
(AND (CONSP COM)
(OR (MEMBER (CAR COM)
'(IL:CONSTANTS IL:MACROS))
(AND (MEMBER (CAR COM)
'(IL:DECLARE\:))
(SOME #'EARLY-P (CDR COM)))))))
(DOLIST (COM COMS-LIST)
(IF (EARLY-P COM)
(PUSH COM EARLY-LIST)
(PUSH COM LATE-LIST)))
(NCONC (NREVERSE EARLY-LIST)
(NREVERSE LATE-LIST)))))
(DEFUN MAKE-EXPORT-FORM (LIST-OF-SYMBOLS)
(LET (SORTED)
(DOLIST (S LIST-OF-SYMBOLS)
(LET ((A (ASSOC (SYMBOL-PACKAGE S)
SORTED)))
(IF A
(PUSH S (CDR A))
(PUSH (CONS (SYMBOL-PACKAGE S)
(LIST S))
SORTED))))
(CONS 'PROGN (MAPCAR #'(LAMBDA (P)
`(EXPORT (MAPCAR 'INTERN ',(MAPCAR 'STRING (CDR P))
',(PACKAGE-NAME (CAR P)))))
SORTED))))
(DEFPARAMETER *WALKER-TEMPLATES*
'(BLOCK (NIL NIL REPEAT (EVAL))
CATCH
(NIL EVAL REPEAT (EVAL))
CHECK-TYPE
(NIL EVAL REPEAT (NIL))
COMPILER-LET
(NIL (REPEAT (NIL EVAL))
REPEAT
(EVAL))
DECLARE
(REPEAT (NIL))
EVAL-WHEN
(NIL QUOTE REPEAT (EVAL))
FLET
(NIL (REPEAT ((NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))))
REPEAT
(EVAL))
FUNCTION
(NIL CALL)
GO
(NIL QUOTE)
IF
(NIL REPEAT (EVAL))
LABELS
(NIL (REPEAT ((NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))))
REPEAT
(EVAL))
LAMBDA
(NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
LET
(NIL BINDING-CONTOUR (REPEAT ((NIL EVAL)))
REPEAT
(EVAL))
LET*
(NIL BINDING-CONTOUR (REPEAT ((NIL EVAL)))
REPEAT
(EVAL))
LOCALLY
(NIL REPEAT (EVAL))
MACROLET
(NIL (REPEAT ((NIL NIL REPEAT (EVAL))))
REPEAT
(EVAL))
MULTIPLE-VALUE-CALL
(NIL EVAL REPEAT (EVAL))
MULTIPLE-VALUE-LIST
(NIL EVAL)
MULTIPLE-VALUE-PROG1
(NIL RETURN REPEAT (EVAL))
MULTIPLE-VALUE-SETQ
(NIL (REPEAT (SET))
EVAL)
MULTIPLE-VALUE-BIND
(NIL BINDING-CONTOUR (REPEAT (SET))
REPEAT
(EVAL))
IL:NLSETQ
(NIL REPEAT (EVAL))
PROGN
(NIL REPEAT (EVAL))
PROGV
(NIL EVAL EVAL REPEAT (EVAL))
QUOTE
(NIL QUOTE)
RETURN-FROM
(NIL QUOTE REPEAT (RETURN))
SETQ
(NIL REPEAT (SET EVAL))
SETF
(NIL REPEAT (SET EVAL))
TAGBODY
(NIL REPEAT (EVAL))
THE
(NIL QUOTE EVAL)
THROW
(NIL EVAL EVAL)
UNLESS
(NIL REPEAT (EVAL))
UNWIND-PROTECT
(NIL RETURN REPEAT (EVAL))
WHEN
(NIL REPEAT (EVAL))
DO
(NIL BINDING-CONTOUR (REPEAT ((BINDING REPEAT (EVAL))))
(EVAL EVAL)
REPEAT
(EVAL))
DO*
(NIL BINDING-CONTOUR (REPEAT ((BINDING REPEAT (EVAL))))
(EVAL EVAL)
REPEAT
(EVAL))
DOLIST
(NIL (NIL EVAL)
REPEAT
(EVAL))
DOTIMES
(NIL (NIL EVAL)
REPEAT
(EVAL))
PROG
(NIL BINDING-CONTOUR (REPEAT ((BINDING EVAL)))
REPEAT
(EVAL))
PROG*
(NIL BINDING-CONTOUR (REPEAT ((BINDING EVAL)))
REPEAT
(EVAL))
COND
(NIL REPEAT ((TEST REPEAT (EVAL))))
DEFINE-SETF-METHOD
(NIL BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
DEFUN
(NIL NAME BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
DEFMACRO
(NIL NAME BINDING-CONTOUR PARAMETER-LIST REPEAT (EVAL))
CASE
(NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
ECASE
(NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
TYPECASE
(NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
ETYPECASE
(NIL EVAL REPEAT ((NIL REPEAT (EVAL))))
XCL:DEFDEFINER
(NIL NIL NIL NIL REPEAT (EVAL))
INCF
(NIL EVAL EVAL)
DECF
(NIL EVAL EVAL)
WITH-INPUT-FROM-STRING
(NIL (NIL EVAL REPEAT (EVAL))
REPEAT
(EVAL))
WITH-OUTPUT-TO-STRING
(NIL (NIL EVAL)
REPEAT
(EVAL))
WITH-OPEN-FILE
(NIL (NIL REPEAT (EVAL))
REPEAT
(EVAL))
LOOP
(NIL REPEAT (EVAL))
POP
(NIL EVAL)
PUSH
(NIL EVAL EVAL)
PUSHNEW
(NIL EVAL EVAL REPEAT EVAL)))
(DEFUN GET-WALKER-TEMPLATE (FN)
(GETF *WALKER-TEMPLATES* FN NIL))
(DEFUN WALK-FORM-INTERNAL (FORM &AUX NEWFORM NEWNEWFORM WALK-NO-MORE-P MACROP FN TEMPLATE)
(COND
((ATOM FORM)
(WHEN (AND (SYMBOLP FORM)
(NOT (NULL *CURRENT-FREE-REFERENCES*))
(NOT (KEYWORDP FORM))
(NOT (MEMBER FORM '(T NIL)))
(NULL (ASSOC FORM *LOCALS*)))
(IL:* IL:|;;| "Almost certainly a free ref. Note for later analysis.")
(PUSHNEW FORM *CURRENT-FREE-REFERENCES*))
FORM)
((SETQ TEMPLATE (GET-WALKER-TEMPLATE (SETQ FN (CAR FORM))))
(IF (SYMBOLP TEMPLATE)
(FUNCALL TEMPLATE FORM)
(WALK-TEMPLATE FORM TEMPLATE)))
((AND (SYMBOLP FN)
(OR (GET FN 'CONVERT-FORM)
(EQ (CAR (GET FN 'IL:CLISPWORD))
'IL:FORWORD)))
(CONVERT FORM))
((AND (SYMBOLP FN)
(MACRO-FUNCTION FN))
(LET ((*CURRENT-EXPRESSION* FORM))
(WARN "Macro form ~s not translated" FN))
FORM)
((AND (SYMBOLP FN)
(NOT (FBOUNDP FN))
(SPECIAL-FORM-P FN))
(UNKNOWN-MACRO-FORM FORM))
(T
(IL:* IL:|;;| "Otherwise, walk the form as if its just a standard ")
(IL:* IL:|;;| "functioncall using a template for standard function")
(IL:* IL:|;;| "call.")
(WALK-TEMPLATE FORM '(CALL REPEAT (EVAL))))))
(DEFUN WALK-TEMPLATE (FORM TEMPLATE)
(IF (ATOM TEMPLATE)
(ECASE TEMPLATE
((EVAL SET FUNCTION TEST EFFECT RETURN)
(WHEN *WALKER-FIND-PARAMETER-LIST*
(THROW 'PARAMETER-LIST NIL))
(WALK-FORM-INTERNAL FORM))
((NIL QUOTE) FORM)
((BINDING)
(IL:* IL:|;;| "This should only appear inside (after) a BINDING-CONTOUR...")
(WHEN (SYMBOLP FORM)
(IL:* IL:|;;| "Perhaps this should note if FORM is declared special somehow...")
(PUSH (CONS FORM ':LOCAL)
*LOCALS*)
(PUSHNEW FORM *CURRENT-LOCALS*))
FORM)
((LAMBDA CALL) (COND
((SYMBOLP FORM)
(UNLESS (NULL *CURRENT-FUNCTION-CALLS*)
(PUSHNEW FORM *CURRENT-FUNCTION-CALLS*))
FORM)
(T
(IL:* IL:|;;| "Have we a \"#'foo\" here?")
(WHEN (AND (CONSP FORM)
(EQ (CAR FORM)
'FUNCTION)
(NULL (CDDR FORM))
(SYMBOLP (SECOND FORM)))
(IL:* IL:|;;| "Record it if we do...")
(PUSHNEW (SECOND FORM)
*CURRENT-FUNCTION-CALLS*))
(WALK-FORM-INTERNAL FORM))))
((NAME)
(WHEN (NULL *CURRENT-FUNCTION-CALLS*)
(IL:* IL:|;;| "Don't record name in a nested def, if we ever see one.")
(SETQ *CURRENT-DEFINITION* FORM)
(PUSH FORM *CURRENT-FUNCTION-CALLS*)
(PUSH FORM *CURRENT-FREE-REFERENCES*))
FORM)
((PARAMETER) (IF (SYMBOLP FORM)
(WALK-TEMPLATE FORM 'BINDING)
(WALK-TEMPLATE FORM '(BINDING EVAL REPEAT (BINDING)))))
((PARAMETER-LIST)
(WHEN *WALKER-FIND-PARAMETER-LIST*
(IL:* IL:|;;| "Some code-analysis stuff uses this.")
(THROW 'PARAMETER-LIST FORM))
(WALK-TEMPLATE FORM '(REPEAT (PARAMETER)))))
(CASE (CAR TEMPLATE)
(REPEAT (WALK-TEMPLATE-HANDLE-REPEAT FORM (CDR TEMPLATE)
(IL:* IL:|;;| "For the case where nothing happens")
(IL:* IL:|;;| "after the repeat optimize out the")
(IL:* IL:|;;| "call to length.")
(IF (NULL (CDDR TEMPLATE))
NIL
(NTHCDR (- (LENGTH FORM)
(LENGTH (CDDR TEMPLATE)))
FORM))))
(IF (WALK-TEMPLATE FORM (IF (IF (LISTP (CADR TEMPLATE))
(EVAL (CADR TEMPLATE))
(FUNCALL (CADR TEMPLATE)
FORM))
(CADDR TEMPLATE)
(CADDDR TEMPLATE))))
(BINDING-CONTOUR (LET ((*LOCALS* *LOCALS*))
(WALK-TEMPLATE FORM (CDR TEMPLATE))))
(REMOTE (WALK-TEMPLATE FORM (CADR TEMPLATE)))
(WARN
(WARN (SECOND TEMPLATE))
(IF (NULL (CDDR TEMPLATE))
FORM
(WALK-TEMPLATE FORM (CDDR TEMPLATE))))
(OTHERWISE (COND
((ATOM FORM)
FORM)
(T (RECONS FORM (WALK-TEMPLATE (CAR FORM)
(CAR TEMPLATE))
(WALK-TEMPLATE (CDR FORM)
(CDR TEMPLATE)))))))))
(DEFUN WALK-TEMPLATE-HANDLE-REPEAT (FORM TEMPLATE STOP-FORM)
(IF (EQ FORM STOP-FORM)
(WALK-TEMPLATE FORM (CDR TEMPLATE))
(WALK-TEMPLATE-HANDLE-REPEAT-1 FORM TEMPLATE (CAR TEMPLATE)
STOP-FORM)))
(DEFUN WALK-TEMPLATE-HANDLE-REPEAT-1 (FORM TEMPLATE REPEAT-TEMPLATE STOP-FORM)
(COND
((NULL FORM)
NIL)
((EQ FORM STOP-FORM)
(IF (NULL REPEAT-TEMPLATE)
(WALK-TEMPLATE STOP-FORM (CDR TEMPLATE))
(ERROR
"While handling repeat:
~%~Ran into stop while still in repeat template.")))
((NULL REPEAT-TEMPLATE)
(WALK-TEMPLATE-HANDLE-REPEAT-1 FORM TEMPLATE (CAR TEMPLATE)
STOP-FORM))
(T (RECONS FORM (WALK-TEMPLATE (CAR FORM)
(CAR REPEAT-TEMPLATE))
(WALK-TEMPLATE-HANDLE-REPEAT-1 (CDR FORM)
TEMPLATE
(CDR REPEAT-TEMPLATE)
STOP-FORM)))))
(DEFUN WALK-REPEAT-EVAL (FORM ENV)
(AND FORM (RECONS FORM (WALK-FORM-INTERNAL (CAR FORM))
(WALK-REPEAT-EVAL (CDR FORM)))))
(DEFUN RECONS (X CAR CDR)
(IF (OR (NOT (EQ (CAR X)
CAR))
(NOT (EQ (CDR X)
CDR)))
(CONS CAR CDR)
X))
(DEFUN RELIST (X &REST ARGS)
(RELIST-INTERNAL X ARGS NIL))
(DEFUN RELIST* (X &REST ARGS)
(RELIST-INTERNAL X ARGS 'T))
(DEFUN RELIST-INTERNAL (X ARGS *P)
(IF (NULL (CDR ARGS))
(IF *P
(CAR ARGS)
(LIST (CAR ARGS)))
(RECONS X (CAR ARGS)
(RELIST-INTERNAL (CDR X)
(CDR ARGS)
*P))))
(DEFVAR *GETVALUE-TRANSLATION* :SLOT-VALUE)
(DEFVAR *CURRENT-DEFINITION*)
(DEFVAR *CURRENT-DEFINITION-TYPE*)
(DEFVAR *CURRENT-EXPRESSION*)
(DEFVAR *CURRENT-LOCALS* NIL)
(DEFVAR *FILE-CONTEXT* NIL)
(DEFVAR *WALKER-FIND-PARAMETER-LIST* NIL)
(DEFVAR *WARNINGS-MADE* NIL)
(DEFVAR *PACKAGE-FOR-IL-SYMBOLS* NIL)
(DEFVAR *PACKAGE-FOR-RESULT-FILE* "CL")
(DEFVAR *PARAMETERS-ALWAYS-OPTIONAL* NIL)
(DEFVAR *PROMPT-FOR-UNKNOWN-MACRO-TEMPLATE* NIL)
(DEFVAR *UNKNOWN-MACRO-ACTION* :UM-WARN)
(DEFVAR *ALWAYS-INCLUDE-PROPS* NIL)
(IL:DECLARE\: IL:DONTCOPY
(IL:PUTPROPS IL:IL-CONVERT IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE "IL-CONVERT" :BASE
10))
(IL:PUTPROPS IL:IL-CONVERT IL:FILETYPE :COMPILE-FILE)
)
(IL:PUTPROPS IL:IL-CONVERT IL:COPYRIGHT ("ENVOS Corporation" 1989 1990))
(IL:DECLARE\: IL:DONTCOPY
(IL:FILEMAP (NIL)))
IL:STOP

1
lispusers/MIGRATION/IL-CONVERT.LCOM Normal file
View File

File diff suppressed because one or more lines are too long

420
lispusers/MIGRATION/IL-LOOPS Normal file
View File

@ -0,0 +1,420 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "26-Jan-90 10:12:33" {DSK}/users/welch/migration/IL-LOOPS.;8 28689
changes to%: (FUNCTIONS IL-CONVERT::CONVERT-ONE-CLASS IL-CONVERT::GetValue IL-CONVERT::_Super)
previous date%: "25-Jan-90 14:14:46" {DSK}/users/welch/migration/IL-LOOPS.;6)
(* "
Copyright (c) 1989, 1990 by Savoir, Inc.. All rights reserved.
")
(PRETTYCOMPRINT IL-LOOPSCOMS)
(RPAQQ IL-LOOPSCOMS
((FUNCTIONS IL-CONVERT::@ IL-CONVERT::_ IL-CONVERT::$ IL-CONVERT::_! IL-CONVERT::_Super
IL-CONVERT::_Super? IL-CONVERT::ACTIVE-VALUE-SLOT-SPEC
IL-CONVERT::AVSENDSELF-ACCESSOR-WRITER IL-CONVERT::CONVERT-CLASSES
IL-CONVERT::CONVERT-METHODS IL-CONVERT::CONVERT-ONE-CLASS
IL-CONVERT::CONVERT-ONE-METHOD IL-CONVERT::Class
IL-CONVERT::EVERYFETCH-ACCESSOR-WRITER IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC
IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER IL-CONVERT::FFSENDSELF-ACCESSOR-WRITER
IL-CONVERT::FIRSTFETCH-ACCESSOR-WRITER IL-CONVERT::GETFROMIV-ACCESSOR-WRITER
IL-CONVERT::GetValue)
(PROP IL-CONVERT::CONVERT-COM CLASSES METHODS)
(PROP IL-CONVERT::ACCESSOR-WRITER EveryFetch FFGetFromIV FFSendSelf FirstFetch GetFromIV
AVSendSelf)))
(IL-CONVERT::IL-DEFCONV IL-CONVERT::@ (&REST IL-CONVERT::ARGS)
(LET [(IL-CONVERT::EXPANSION (Parse@ IL-CONVERT::ARGS
'IV]
(OR (AND IL-CONVERT::EXPANSION (IL-CONVERT:CONVERT
IL-CONVERT::EXPANSION)
)
(PROGN (CL:WARN "Unrecognizable @ form")
IL-CONVERT::*CURRENT-EXPRESSION*))))
(IL-CONVERT::IL-DEFCONV IL-CONVERT::_ (IL-CONVERT::INST IL-CONVERT::METH &REST IL-CONVERT::ARGS)
`(,IL-CONVERT::METH ,(IL-CONVERT:CONVERT IL-CONVERT::INST)
,.(IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS)))
(IL-CONVERT::IL-DEFCONV IL-CONVERT::$ (IL-CONVERT::NAME)
(LET ((IL-CONVERT::REC ($! IL-CONVERT::NAME)))
(CL:IF (Class? IL-CONVERT::REC)
`[,(IL-CONVERT::MAKE-FAKE-SYMBOL "FIND-CLASS")
',(IL-CONVERT:CONVERT IL-CONVERT::NAME]
(PROGN (CL:WARN
"$ form doesn't refer to a known class"
)
IL-CONVERT::*CURRENT-EXPRESSION*))))
(IL-CONVERT::IL-DEFCONV IL-CONVERT::_! (IL-CONVERT::INST IL-CONVERT::METH &REST IL-CONVERT::ARGS)
`(CL:FUNCALL ,(IL-CONVERT:CONVERT IL-CONVERT::METH)
,(IL-CONVERT:CONVERT IL-CONVERT::INST)
,.(IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS)))
(IL-CONVERT::IL-DEFCONV IL-CONVERT::_Super (&OPTIONAL IL-CONVERT::OBJ IL-CONVERT::SEL &REST
IL-CONVERT::ARGS)
(DECLARE (IGNORE IL-CONVERT::OBJ IL-CONVERT::SEL))
(CONS (IL-CONVERT::MAKE-FAKE-SYMBOL "CALL-NEXT-METHOD"
)
(IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS)))
(IL-CONVERT::IL-DEFCONV IL-CONVERT::_Super? (IL-CONVERT::OBJ IL-CONVERT::SEL &REST
IL-CONVERT::ARGS)
(DECLARE (IGNORE IL-CONVERT::OBJ IL-CONVERT::SEL)
)
`[AND (,(IL-CONVERT::MAKE-FAKE-SYMBOL "NEXT-METHOD-P"
))
(,(IL-CONVERT::MAKE-FAKE-SYMBOL
"CALL-NEXT-METHOD")
,.(IL-CONVERT::MAPCONVERT IL-CONVERT::ARGS])
(CL:DEFUN IL-CONVERT::ACTIVE-VALUE-SLOT-SPEC (IL-CONVERT::NAME IL-CONVERT::DOC IL-CONVERT::OBJ
IL-CONVERT::CLASS-NAME)
(DECLARE (CL:DECLARATION CL:VALUES)
(CL:VALUES IL-CONVERT::SLOT-SPEC &REST IL-CONVERT::AUX-DEFS))
(CASE IL-CONVERT::*GETVALUE-TRANSLATION*
(:SLOT-VALUE (LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::OBJ))
(CL:WARN "Active value in SLOT-VALUE GetValue mode")
IL-CONVERT::OBJ))
(:ACCESSOR (CASE (ClassName IL-CONVERT::OBJ)
(ExplicitFnActiveValue (IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC
IL-CONVERT::NAME IL-CONVERT::DOC IL-CONVERT::OBJ
IL-CONVERT::CLASS-NAME))
(CL:OTHERWISE
[LET* ((IL-CONVERT::GM (GetIt (Class IL-CONVERT::OBJ)
'GetWrappedValue NIL 'METHOD))
[IL-CONVERT::GMCLASS (CL:SECOND (GETDEF IL-CONVERT::GM 'METHODS]
(IL-CONVERT::PM (GetIt (Class IL-CONVERT::OBJ)
'PutWrappedValue NIL 'METHOD))
(IL-CONVERT::PMCLASS (CL:SECOND (GETDEF IL-CONVERT::PM 'METHODS]
(LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::OBJ))
(CL:WARN "Unconvertable ~a in defclass" (ClassName IL-CONVERT::OBJ)))
IL-CONVERT::OBJ)))
(:ACTIVE-VALUE (LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::OBJ))
(CL:WARN "Active value emulator not written yet")
IL-CONVERT::OBJ))))
(CL:DEFUN IL-CONVERT::AVSENDSELF-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
IL-CONVERT::LOCALSTATE)
[IL-CONVERT:CONVERT `(_ ,IL-CONVERT::SELFVAR ,IL-CONVERT::LOCALSTATE)])
(CL:DEFUN IL-CONVERT::CONVERT-CLASSES (IL-CONVERT::CS)
(IL-CONVERT::MAP-INTO-CONTEXT 'IL-CONVERT::CONVERT-ONE-CLASS IL-CONVERT::CS))
(CL:DEFUN IL-CONVERT::CONVERT-METHODS (IL-CONVERT::MS)
(CONS 'PROGN (IL-CONVERT::MAP-INTO-CONTEXT 'IL-CONVERT::CONVERT-ONE-METHOD IL-CONVERT::MS)))
(CL:DEFUN IL-CONVERT::CONVERT-ONE-CLASS (IL-CONVERT::C)
""
[LET*
((IL-CONVERT::SRC (_ [OR ($! IL-CONVERT::C)
(LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::C))
(CL:WARN "Class not found")
(CL:RETURN-FROM IL-CONVERT::CONVERT-ONE-CLASS
(LIST '* ';; (CL:FORMAT NIL "Class ~a not found."
IL-CONVERT::C]
MakeFileSource))
(IL-CONVERT::CLASSNAME (IL-CONVERT:CONVERT (CL:SECOND IL-CONVERT::SRC)))
(IL-CONVERT::*CURRENT-DEFINITION* IL-CONVERT::CLASSNAME)
(IL-CONVERT::*CURRENT-DEFINITION-TYPE* "Class")
(IL-CONVERT::*CURRENT-FUNCTION-CALLS* (LIST IL-CONVERT::CLASSNAME))
(IL-CONVERT::*CURRENT-FREE-REFERENCES* (LIST IL-CONVERT::CLASSNAME))
(IL-CONVERT::ATTRIBUTES (CDDR IL-CONVERT::SRC))
(IL-CONVERT::META (CDR (CL:ASSOC 'MetaClass IL-CONVERT::ATTRIBUTES)))
(IL-CONVERT::SUPERS (CDR (CL:ASSOC 'Supers IL-CONVERT::ATTRIBUTES)))
(IL-CONVERT::CVS (CDR (CL:ASSOC 'ClassVariables IL-CONVERT::ATTRIBUTES)))
(IL-CONVERT::IVS (CDR (CL:ASSOC 'InstanceVariables IL-CONVERT::ATTRIBUTES)))
IL-CONVERT::PROPS-ALIST IL-CONVERT::AUX-DEFS)
(CL:LABELS
([IL-CONVERT::LOOPS-CONVERT (IL-CONVERT::X)
(COND
[(Class? IL-CONVERT::X)
`(IL-CONVERT::FIND-CLASS ',(IL-CONVERT:CONVERT (_ IL-CONVERT::X ClassName)]
((AnnotatedValue? IL-CONVERT::X)
(IL-CONVERT::AV-CONVERT IL-CONVERT::X))
((CL:CONSP IL-CONVERT::X)
(CL:MAPCAR #'IL-CONVERT::LOOPS-CONVERT IL-CONVERT::X))
((Instance? IL-CONVERT::X)
(LET ((IL-CONVERT::*CURRENT-EXPRESSION* IL-CONVERT::X))
(CL:WARN "Unconvertable LOOPS object in defclass"))
IL-CONVERT::X)
(T (IL-CONVERT:CONVERT IL-CONVERT::X]
(IL-CONVERT::AV-CONVERT (IL-CONVERT::NAME IL-CONVERT::DOC IL-CONVERT::OBJ)
(CL:SETQ IL-CONVERT::OBJ (fetch annotatedValue of IL-CONVERT::OBJ))
(LET [(CL:VALUES (CL:MULTIPLE-VALUE-LIST (IL-CONVERT::ACTIVE-VALUE-SLOT-SPEC
IL-CONVERT::NAME IL-CONVERT::DOC
IL-CONVERT::OBJ IL-CONVERT::CLASSNAME]
(CL:SETQ IL-CONVERT::AUX-DEFS (NCONC IL-CONVERT::AUX-DEFS (CDR CL:VALUES)))
(CAR CL:VALUES)))
(IL-CONVERT::PROCESS-IV
(IL-CONVERT::SPEC &OPTIONAL IL-CONVERT::ALLOC &AUX IL-CONVERT::DOC)
(LET* [(IL-CONVERT::NAME (IL-CONVERT:CONVERT (CL:FIRST IL-CONVERT::SPEC)))
(IL-CONVERT::OBJ (CL:SECOND IL-CONVERT::SPEC))
(IL-CONVERT::DOC (CL:GETF (CDDR IL-CONVERT::SPEC)
'doc))
[IL-CONVERT::CONVERSION (CL:IF (type? annotatedValue IL-CONVERT::OBJ)
(IL-CONVERT::AV-CONVERT IL-CONVERT::NAME IL-CONVERT::DOC
IL-CONVERT::OBJ)
`[,IL-CONVERT::NAME
,@[AND (CDR IL-CONVERT::SPEC)
`(:INITFORM ,(IL-CONVERT::LOOPS-CONVERT
IL-CONVERT::OBJ]
:INITARG
,(CL:INTERN (STRING (CL:FIRST IL-CONVERT::SPEC))
*KEYWORD-PACKAGE*)
,@[AND IL-CONVERT::ALLOC `(:ALLOCATION
,IL-CONVERT::ALLOC]
,@(AND IL-CONVERT::DOC `(:DOCUMENTATION ,IL-CONVERT::DOC])
]
(IL-CONVERT::PROPS (CL:COPY-LIST (CL:IF IL-CONVERT::DOC
(AND (CDDR (CDDR IL-CONVERT::SPEC))
(CDDR IL-CONVERT::SPEC))
(CDDR IL-CONVERT::SPEC))]
(* ;; "The following (when not quoted) fails to compile, for some reason:")
'(CL:REMF IL-CONVERT::PROPS 'doc)
(CL:WHEN IL-CONVERT::PROPS
(CL:PUSH (CONS IL-CONVERT::NAME IL-CONVERT::PROPS)
IL-CONVERT::PROPS-ALIST))
IL-CONVERT::CONVERSION)))
(LET [(IL-CONVERT::FORM `(,(IL-CONVERT::MAKE-FAKE-SYMBOL "DEFCLASS")
,IL-CONVERT::CLASSNAME
,(IL-CONVERT::MAPCONVERT IL-CONVERT::SUPERS)
[,@(CL:REMOVE-IF 'NULL (CL:MAPCAR #'IL-CONVERT::PROCESS-IV
IL-CONVERT::IVS))
,@(CL:REMOVE-IF 'NULL (for IL-CONVERT::CV in IL-CONVERT::CVS
collect (IL-CONVERT::PROCESS-IV
IL-CONVERT::CV :CLASS)))
,@(AND (OR IL-CONVERT::PROPS-ALIST IL-CONVERT::*ALWAYS-INCLUDE-PROPS*
)
`(IL-CONVERT::.PROPS-ALIST. :INITFORM '
,
IL-CONVERT::PROPS-ALIST
]
,@(CL:UNLESS (EQ (CAR IL-CONVERT::META)
'Class)
[LET [(IL-CONVERT::*CURRENT-EXPRESSION* (IL-CONVERT:CONVERT
(CAR IL-CONVERT::META]
(CL:WARN "Metaclass might be incorrect")
`(:METACLASS ,IL-CONVERT::*CURRENT-EXPRESSION*])]
(CL:IF IL-CONVERT::AUX-DEFS
`(PROGN ,IL-CONVERT::FORM ,.IL-CONVERT::AUX-DEFS)
IL-CONVERT::FORM)])
(CL:DEFUN IL-CONVERT::CONVERT-ONE-METHOD (IL-CONVERT::M)
(LET* ((IL-CONVERT::METHOD-BODY (\DEFINE-TYPE-GETDEF IL-CONVERT::M 'METHOD-FNS))
[IL-CONVERT::METHOD-CLASS (CL:FIRST (CL:FIRST (CL:SECOND IL-CONVERT::METHOD-BODY]
[IL-CONVERT::METHOD-SELECTOR (CL:SECOND (CL:FIRST (CL:SECOND IL-CONVERT::METHOD-BODY]
(IL-CONVERT::METHOD-ARGS (CDR (CL:SECOND IL-CONVERT::METHOD-BODY)))
(IL-CONVERT::METHOD-FNBODY (CDDR IL-CONVERT::METHOD-BODY))
(IL-CONVERT::*CURRENT-DEFINITION* IL-CONVERT::M)
(IL-CONVERT::*CURRENT-DEFINITION-TYPE* "Function")
(IL-CONVERT::*CURRENT-FUNCTION-CALLS* (LIST IL-CONVERT::M))
(IL-CONVERT::*CURRENT-FREE-REFERENCES* (LIST IL-CONVERT::M))
(IL-CONVERT::*SELF-VARIABLE* (CL:FIRST IL-CONVERT::METHOD-ARGS)))
(DECLARE (CL:SPECIAL IL-CONVERT::*SELF-VARIABLE*))
(CL:VALUES [CL:MULTIPLE-VALUE-BIND (IL-CONVERT::NEW-VARLST IL-CONVERT::VARNAMES)
(IL-CONVERT::EXPAND-VARLIST IL-CONVERT::METHOD-ARGS)
[LET ((IL-CONVERT::*LOCALS* (CL:COPY-LIST IL-CONVERT::VARNAMES)))
(CL:WHEN (AND (CDR IL-CONVERT::NEW-VARLST)
IL-CONVERT::*PARAMETERS-ALWAYS-OPTIONAL*)
(CL:PUSH '&OPTIONAL (CDR IL-CONVERT::NEW-VARLST)))]
`(,(IL-CONVERT::MAKE-FAKE-SYMBOL 'IL-CONVERT::DEFMETHOD)
,IL-CONVERT::METHOD-SELECTOR
[(,(CL:FIRST IL-CONVERT::NEW-VARLST)
,IL-CONVERT::METHOD-CLASS)
,@(CDR IL-CONVERT::NEW-VARLST)
,@(AND IL-CONVERT::*ADD-REST-ARG* '(&REST IL-CONVERT::$EXTRA-ARGS$]
,.(IL-CONVERT::MAPCONVERT IL-CONVERT::METHOD-FNBODY]
(CL:NREVERSE IL-CONVERT::*CURRENT-FUNCTION-CALLS*)
(CL:NREVERSE IL-CONVERT::*CURRENT-FREE-REFERENCES*))))
(IL-CONVERT::IL-DEFCONV IL-CONVERT::Class (IL-CONVERT::X)
`(,(IL-CONVERT::MAKE-FAKE-SYMBOL 'IL-CONVERT::CLASS-OF)
,(IL-CONVERT:CONVERT IL-CONVERT::X)))
(CL:DEFUN IL-CONVERT::EVERYFETCH-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
IL-CONVERT::LOCALSTATE)
(CL:IF (OR (CL:SYMBOLP IL-CONVERT::LOCALSTATE)
(IL-CONVERT::FAKE-SYMBOL-P IL-CONVERT::LOCALSTATE))
`(CL:FUNCALL ,(IL-CONVERT:CONVERT IL-CONVERT::LOCALSTATE))
(IL-CONVERT:CONVERT IL-CONVERT::LOCALSTATE)))
(CL:DEFUN IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC (IL-CONVERT::NAME IL-CONVERT::DOC
IL-CONVERT::OBJ
IL-CONVERT::CLASS-NAME)
(* ;; "Old-style AVs done here. ")
(LET* ((IL-CONVERT::LS (@ IL-CONVERT::OBJ localState))
(IL-CONVERT::GF (@ IL-CONVERT::OBJ getFn))
(IL-CONVERT::PF (@ IL-CONVERT::OBJ putFn))
(IL-CONVERT::CODEWRITER (GET IL-CONVERT::GF 'IL-CONVERT::ACCESSOR-WRITER))
IL-CONVERT::DEFS)
(* ;; " Write the accessor...")
(CL:UNLESS IL-CONVERT::CODEWRITER
(LET ((IL-CONVERT::*CURRENT-EXPRESSION* (LIST IL-CONVERT::NAME :INITFORM IL-CONVERT::OBJ
)))
(CL:WARN "No accessor-writer for ~a" IL-CONVERT::GF)
(CL:RETURN-FROM IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC
IL-CONVERT::*CURRENT-EXPRESSION*)))
(LET* [(CL:NAMESTRING (CL:IF (IL-CONVERT::FAKE-SYMBOL-P IL-CONVERT::NAME)
(IL-CONVERT::FAKE-SYMBOL-NAME IL-CONVERT::NAME)
(STRING IL-CONVERT::NAME)))
[IL-CONVERT::VARNAME (AND (CL:CONSP IL-CONVERT::CODEWRITER)
(CDR IL-CONVERT::CODEWRITER)
(IL-CONVERT::MAKE-FAKE-SYMBOL (CL:CONCATENATE 'STRING
"!CACHE-FOR-"
CL:NAMESTRING]
(IL-CONVERT::CODE (CL:FUNCALL (CL:IF (CL:CONSP IL-CONVERT::CODEWRITER)
(CAR IL-CONVERT::CODEWRITER)
IL-CONVERT::CODEWRITER)
IL-CONVERT::VARNAME
'self IL-CONVERT::LS))
(IL-CONVERT::ACCESSOR (IL-CONVERT::MAKE-FAKE-SYMBOL (CL:CONCATENATE 'STRING
"!ACCESSOR-FOR-"
CL:NAMESTRING]
(CL:PUSH `(,(IL-CONVERT::MAKE-FAKE-SYMBOL "DEFMETHOD")
,IL-CONVERT::ACCESSOR
((,(IL-CONVERT::MAKE-FAKE-SYMBOL "SELF")
,IL-CONVERT::CLASS-NAME))
,IL-CONVERT::CODE)
IL-CONVERT::DEFS)
(* ;; "Look at putfn...")
(CL:UNLESS (CL:MEMBER IL-CONVERT::PF '(ReplaceMe NoUpdatePermitted))
(LET [(IL-CONVERT::CODEWRITER (GET IL-CONVERT::PF 'IL-CONVERT::ACCESSOR-WRITER]
(CL:UNLESS IL-CONVERT::CODEWRITER
(LET ((IL-CONVERT::*CURRENT-EXPRESSION* (LIST IL-CONVERT::NAME :INITFORM
IL-CONVERT::OBJ)))
(CL:WARN "No accessor-writer for ~a" IL-CONVERT::PF)
(CL:RETURN-FROM IL-CONVERT::EXPLICIT-FN-ACTIVE-VALUE-SLOT-SPEC
IL-CONVERT::*CURRENT-EXPRESSION*)))
(LET ((IL-CONVERT::CODE (CL:FUNCALL IL-CONVERT::CODEWRITER
IL-CONVERT::VARNAME 'self IL-CONVERT::LS)))
(CL:PUSH `(,(IL-CONVERT::MAKE-FAKE-SYMBOL "DEFMETHOD")
(CL:SETF ,IL-CONVERT::ACCESSOR)
((self ,IL-CONVERT::CLASS-NAME))
,IL-CONVERT::CODE)
IL-CONVERT::DEFS))))
(* ;; "Make slot spec...")
(CL:APPLY 'CL:VALUES (* ; "values-list* y'might say")
[AND IL-CONVERT::VARNAME
`(,IL-CONVERT::VARNAME ,@(AND (EQ IL-CONVERT::PF 'ReplaceMe)
`(:WRITER (CL:SETF ,IL-CONVERT::ACCESSOR]
IL-CONVERT::DEFS))))
(CL:DEFUN IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
IL-CONVERT::LOCALSTATE)
`(CL:IF (IL-CONVERT::SLOT-BOUNDP ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
[CL:SETF (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::LOCALSTATE]))
(CL:DEFUN IL-CONVERT::FFSENDSELF-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
IL-CONVERT::LOCALSTATE)
`(CL:IF (IL-CONVERT::SLOT-BOUNDP ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
[CL:SETF (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
,(IL-CONVERT:CONVERT `(_ ,IL-CONVERT::SELFVAR ,IL-CONVERT::LOCALSTATE)]))
(CL:DEFUN IL-CONVERT::FIRSTFETCH-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
IL-CONVERT::LOCALSTATE)
`(CL:IF (IL-CONVERT::SLOT-BOUNDP ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
(CL:SETF (IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::VARNAME)
,(CL:IF (OR (CL:SYMBOLP IL-CONVERT::LOCALSTATE)
(IL-CONVERT::FAKE-SYMBOL-P IL-CONVERT::LOCALSTATE))
`(CL:FUNCALL ,IL-CONVERT::LOCALSTATE)
IL-CONVERT::LOCALSTATE))))
(CL:DEFUN IL-CONVERT::GETFROMIV-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR
IL-CONVERT::LOCALSTATE)
`(IL-CONVERT::SLOT-VALUE ,IL-CONVERT::SELFVAR ',IL-CONVERT::LOCALSTATE))
(IL-CONVERT::IL-DEFCONV IL-CONVERT::GetValue (IL-CONVERT::INST &OPTIONAL IL-CONVERT::VAR
IL-CONVERT::PROP)
[COND
(IL-CONVERT::PROP (LIST (
IL-CONVERT::MAKE-FAKE-SYMBOL
"SLOT-PROP-VALUE")
(IL-CONVERT:CONVERT
IL-CONVERT::INST)
(IL-CONVERT:CONVERT
IL-CONVERT::VAR)
(IL-CONVERT:CONVERT
IL-CONVERT::PROP)))
[IL-CONVERT::VAR
(CL:ECASE IL-CONVERT::*GETVALUE-TRANSLATION*
(:SLOT-VALUE (LIST
IL-CONVERT::*SLOT-VALUE-FAKESYM*
(IL-CONVERT:CONVERT
IL-CONVERT::INST)
(IL-CONVERT:CONVERT
IL-CONVERT::VAR)))
(:ACCESSOR
(CL:IF (AND (CL:CONSP IL-CONVERT::VAR)
(EQ (CAR IL-CONVERT::VAR)
'QUOTE))
(LIST
[IL-CONVERT::MAKE-FAKE-SYMBOL
(CL:CONCATENATE
'STRING "access-"
(LET [(IL-CONVERT::NEWNAME
(IL-CONVERT:CONVERT
(CL:SECOND IL-CONVERT::VAR
]
(CL:IF (
IL-CONVERT::FAKE-SYMBOL-P
IL-CONVERT::NEWNAME)
(
IL-CONVERT::FAKE-SYMBOL-NAME
IL-CONVERT::NEWNAME)
(CL:SYMBOL-NAME
IL-CONVERT::NEWNAME
))]
(IL-CONVERT:CONVERT IL-CONVERT::INST
))
(PROGN (CL:WARN
"Unquoted IV spec in :ACCESSOR GetValue mode"
)
IL-CONVERT::*CURRENT-EXPRESSION*
)))
(:ACTIVE-VALUE (IL-CONVERT::MAKE-FAKE-SYMBOL
"ACTIVE-VALUE"
(IL-CONVERT:CONVERT
IL-CONVERT::INST)
(IL-CONVERT:CONVERT
IL-CONVERT::VAR))))]
(T (IL-CONVERT:CONVERT `(GetValue self
,IL-CONVERT::INST])
(PUTPROPS CLASSES IL-CONVERT::CONVERT-COM IL-CONVERT::CONVERT-CLASSES)
(PUTPROPS METHODS IL-CONVERT::CONVERT-COM IL-CONVERT::CONVERT-METHODS)
(PUTPROPS EveryFetch IL-CONVERT::ACCESSOR-WRITER IL-CONVERT::EVERYFETCH-ACCESSOR-WRITER)
(PUTPROPS FFGetFromIV IL-CONVERT::ACCESSOR-WRITER (IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER . T))
(PUTPROPS FFSendSelf IL-CONVERT::ACCESSOR-WRITER (IL-CONVERT::FFSENDSELF-ACCESSOR-WRITER . T))
(PUTPROPS FirstFetch IL-CONVERT::ACCESSOR-WRITER (IL-CONVERT::FIRSTFETCH-ACCESSOR-WRITER . T))
(PUTPROPS GetFromIV IL-CONVERT::ACCESSOR-WRITER (IL-CONVERT::FFGETFROMIV-ACCESSOR-WRITER))
(PUTPROPS AVSendSelf IL-CONVERT::ACCESSOR-WRITER IL-CONVERT::AVSENDSELF-ACCESSOR-WRITER)
(PUTPROPS IL-LOOPS COPYRIGHT ("Savoir, Inc." 1989 1990))
(DECLARE%: DONTCOPY
(FILEMAP (NIL)))
STOP

1
lispusers/MIGRATION/IL-LOOPS.LCOM Normal file
View File

File diff suppressed because one or more lines are too long

214
lispusers/MIGRATION/IL-RECORD Normal file
View File

@ -0,0 +1,214 @@
(DEFINE-FILE-INFO PACKAGE "IL-CONVERT" READTABLE "XCL")
(IL:FILECREATED "14-Sep-89 10:03:02" IL:|{DSK}/python2/aria/migration/interlisp/IL-RECORD.;2| 21305
IL:|changes| IL:|to:| (IL:FUNCTIONS MAKE-RECORD-ACCESSORS |fetch| |replace| |DO-create|)
IL:|previous| IL:|date:| " 2-Mar-89 13:12:40" IL:|{DSK}/users/eweaver/convert/IL-RECORD.;4|)
; Copyright (c) 1989 by ENVOS Corporation. All rights reserved.
(IL:PRETTYCOMPRINT IL:IL-RECORDCOMS)
(IL:RPAQQ IL:IL-RECORDCOMS ((IL:* IL:\| "chapter 8") (IL:VARIABLES *RECORD-TYPES*) (IL:FUNCTIONS ADD-EXPORTS ASSOCRECORD PROPRECORD ATOMRECORD BLOCKRECORD) (IL:FUNCTIONS ARRAYRECORD DEFINE-ARRAYRECORD-STRUCTURE) (IL:* IL:\; " ^'(arrayrecord foo (a b c) b _ 3)") (IL:FUNCTIONS INTERLISP-COMMENT-P) (IL:FUNCTIONS RECORD) (IL:FUNCTIONS TYPERECORD FLATTEN MAKE-RECORD-ACCESSORS DEFINE-RECORD-STRUCTURE) (IL:* IL:\; " ^'(record foo (a b . c) b _ 3) ") (IL:* IL:|;;| "
; this version defines a defstruct which is not really the same
; as the IL record type.
(defun
define-record-structure (record-name record-fields named record-tail)
(let* ((name-string (symbol-name record-name))
(struct-name (intern name-string))
(*current-record-name* record-name)
(slots nil))
(declare (special *current-record-name*))
(setq record-fields (make-true-list record-fields))
(do ((fields record-fields (rest fields))
field)
((null fields) (setq slots (nreverse slots)))
(setq field (first fields))
(cond
((null field )
(warn \"NIL as record field name not supported\"))
((atom field) (push field slots))
((eq (first field) '*)) ;Ignore comments
(t (setq slots (append (reverse (flatten field)) slots)))))
(setf (gethash struct-name *record-types*) slots)
(multiple-value-bind
(record-tail-forms record-tail-inits)
(process-record-tail record-tail)
(add-exports
`((defstruct
,struct-name
(:type list)
(:named ,named)
,@(mapcar
#'(lambda (slot &aux pair)
(if (setq pair (assoc slot record-tail-inits))
`(,slot ,(cdr pair))
slot))
slots))
,@record-tail-forms)))))
") (IL:* IL:|;;| "Returns two values: a list of forms to be generated, and a list of (slot . init-form) pairs.") (IL:FUNCTIONS PROCESS-RECORD-TAIL) (IL:* IL:|;;| "Define user-created access functions. It doesn't matter if these fields are part of the structure or not. If so, they will redefine the access functions created by defstruct.") (IL:FUNCTIONS ACCESSFNS) (IL:* IL:|;;| " (convert '(accessfns pilotbbt ((pbtsource foo1 foo2))))") (IL:FUNCTIONS DATATYPE FIELD-TO-SLOT-TYPE /DECLAREDATATYPE FIND-RECORD-TYPE FIND-RECORD-FIELDS |fetch| |replace| TYPE? |create| |DO-create|) (IL:P (IL-COPYCONV |fetch| FETCH) (IL-COPYCONV |fetch| |ffetch|) (IL-COPYCONV |ffetch| FFETCH) (IL-COPYCONV |replace| REPLACE) (IL-COPYCONV |replace| |freplace|) (IL-COPYCONV |freplace| FREPLACE) (IL-COPYCONV TYPE? |type?|) (IL-COPYCONV |create| CREATE)) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IL-RECORD))
)
(IL:* IL:\| "chapter 8")
(DEFVAR *RECORD-TYPES* (MAKE-HASH-TABLE :SIZE 100))
(DEFUN ADD-EXPORTS (FORMS &AUX (EXPORT-LIST NIL)) (DOLIST (FORM FORMS) (AND (CONSP FORM) (MEMBER (FIRST FORM) (QUOTE (DEFUN DEFMACRO)) :TEST (FUNCTION EQ)) (PUSH (SECOND FORM) EXPORT-LIST))) (IF EXPORT-LIST (IL:BQUOTE (PROGN (EXPORT (QUOTE (IL:\\\, (REVERSE EXPORT-LIST)))) (IL:\\\,@ FORMS))) (PROGN-IF-NEEDED FORMS)))
(IL-DEFCONV ASSOCRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-NAME RECORD-FIELDS RECORD-TAIL)) (WARN "ASSOCRECORD not supported") (IL:* IL:|;;| "
(setf
(gethash record-name *record-types*)
(mapcar #'car record-fields))
(process-record-tail record-tail)
"))
(IL-DEFCONV PROPRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-NAME RECORD-FIELDS RECORD-TAIL)) (WARN "PROPRECORD not supported") (IL:* IL:|;;| "
(setf
(gethash record-name *record-types*)
(do ((fields record-fields (rest (rest fields)))
(slots nil))
((endp fields) (nreverse slots))
(push (first fields) slots))
(process-record-tail record-tail))
"))
(IL-DEFCONV ATOMRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-NAME RECORD-FIELDS RECORD-TAIL)) (WARN "ATOMRECORD not supported"))
(IL-DEFCONV BLOCKRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (IGNORE RECORD-TAIL)) (DECLARE (SPECIAL *ADD-TO-RECORD-DEFN*)) (WARN "BLOCKRECORD not supported") (DO ((FIELDS RECORD-FIELDS (REST FIELDS)) (SLOTS NIL) FIELD) ((ENDP FIELDS) (SETF (GETHASH RECORD-NAME *RECORD-TYPES*) (IF (BOUNDP (QUOTE *ADD-TO-RECORD-DEFN*)) (APPEND (NREVERSE SLOTS) (GETHASH RECORD-NAME *RECORD-TYPES*)) (NREVERSE SLOTS)))) (SETQ FIELD (FIRST FIELDS)) (WHEN (CONSP FIELD) (SETQ FIELD (FIRST FIELD))) (WHEN (AND FIELD (NOT (INTEGERP FIELD))) (PUSH FIELD SLOTS))) NIL)
(IL-DEFCONV ARRAYRECORD (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (DEFINE-ARRAYRECORD-STRUCTURE RECORD-NAME RECORD-FIELDS RECORD-TAIL))
(DEFUN DEFINE-ARRAYRECORD-STRUCTURE (RECORD-NAME RECORD-FIELDS RECORD-TAIL) (LET ((*CURRENT-RECORD-NAME* RECORD-NAME)) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (MULTIPLE-VALUE-BIND (RECORD-TAIL-FORMS RECORD-TAIL-INITS) (PROCESS-RECORD-TAIL RECORD-TAIL) (LET ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (FIELD-FNS NIL) (INITS NIL) (KEYS NIL) CREATE-FN (LENGTH 0)) (DO ((I 0 (1+ I)) (FIELDS RECORD-FIELDS (REST FIELDS)) FIELD) ((ENDP FIELDS) (SETQ FIELD-FNS (NREVERSE FIELD-FNS)) (SETQ INITS (NREVERSE INITS)) (SETQ KEYS (NREVERSE KEYS))) (IL:* IL:|;;| "Define accessor functions. We don't need to define") (IL:* IL:|;;| "setf methods because the accessors are actually") (IL:* IL:|;;| "macros which generate calls to svref, and setf") (IL:* IL:\; "already knows how to handle svref.") (SETQ FIELD (FIRST FIELDS)) (INCF LENGTH) (COND ((INTEGERP FIELD) (INCF I (1- FIELD)) (INCF LENGTH (1- FIELD))) ((NULL FIELD)) (T (PUSH (IL:BQUOTE (DEFMACRO (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME FIELD)))) (X) (IL:\\\, (MAKE-BQ (IL:BQUOTE (SVREF (IL:\\\, (MAKE-MACRO-ARG :ELEMENT (QUOTE X))) (IL:\\\, I))))))) FIELD-FNS) (LET ((SVAR (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME FIELD) "-SET")))) (PUSH (IL:BQUOTE (WHEN (IL:\\\, SVAR) (SETF (SVREF $X$ (IL:\\\, I)) (IL:\\\, FIELD)))) INITS) (PUSH (IL:BQUOTE ((IL:\\\, FIELD) (IL:\\\, (CDR (ASSOC FIELD RECORD-TAIL-INITS))) (IL:\\\, SVAR))) KEYS))))) (SETQ CREATE-FN (IL:BQUOTE (DEFUN (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (&KEY (IL:\\\,@ KEYS)) (LET (($X$) (MAKE-ARRAY (IL:\\\, LENGTH))) (IL:\\\,@ INITS) $X$)))) (ADD-EXPORTS (IL:BQUOTE ((IL:\\\, CREATE-FN) (IL:\\\,@ FIELD-FNS) (IL:\\\,@ RECORD-TAIL-FORMS))))))))
(IL:* IL:\; " ^'(arrayrecord foo (a b c) b _ 3)")
(DEFUN INTERLISP-COMMENT-P (X) (AND (CONSP X) (EQ (FIRST X) (QUOTE *))))
(IL-DEFCONV RECORD (&REST ARGS) (SETQ ARGS (REMOVE-IF (FUNCTION INTERLISP-COMMENT-P) ARGS)) (DEFINE-RECORD-STRUCTURE (FIRST ARGS) (SECOND ARGS) NIL (REST (REST ARGS))))
(IL-DEFCONV TYPERECORD (&REST ARGS) (SETQ ARGS (REMOVE-IF (FUNCTION INTERLISP-COMMENT-P) ARGS)) (DEFINE-RECORD-STRUCTURE (FIRST ARGS) (SECOND ARGS) T (REST (REST ARGS))))
(DEFUN FLATTEN (X) (COND ((CONSP X) (APPEND (FLATTEN (CAR X)) (FLATTEN (CDR X)))) ((NULL X) NIL) (T (CONS X NIL))))
(DEFUN MAKE-RECORD-ACCESSORS (RECORD-NAME TREE PATH) (COND ((NULL TREE) NIL) ((ATOM TREE) (LET ((ACCESSOR-NAME (INTERN (CONCATENATE (QUOTE STRING) RECORD-NAME "-" (SYMBOL-NAME TREE))))) (IL:BQUOTE ((DEFSETF (IL:\\\, ACCESSOR-NAME) (X) (VAL) (LIST (QUOTE SETF) (IL:\\\, (MAKE-BQ (SUBST (MAKE-MACRO-ARG :ELEMENT (QUOTE X)) T PATH :TEST (FUNCTION EQ)))) VAL)) (DEFMACRO (IL:\\\, ACCESSOR-NAME) (X) (IL:\\\, (MAKE-BQ (SUBST (MAKE-MACRO-ARG :ELEMENT (QUOTE X)) T PATH :TEST (FUNCTION EQ))))))))) ((EQ (CAR TREE) (QUOTE *)) NIL) (T (APPEND (MAKE-RECORD-ACCESSORS RECORD-NAME (CAR TREE) (IL:BQUOTE (CAR (IL:\\\, PATH)))) (MAKE-RECORD-ACCESSORS RECORD-NAME (CDR TREE) (IL:BQUOTE (CDR (IL:\\\, PATH))))))))
(DEFUN DEFINE-RECORD-STRUCTURE (RECORD-NAME RECORD-FIELDS NAMED RECORD-TAIL) (LET* ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (STRUCT-NAME (INTERN NAME-STRING)) (*CURRENT-RECORD-NAME* RECORD-NAME) (SLOTS (REMOVE-IF (FUNCTION NULL) (FLATTEN RECORD-FIELDS))) (ACCESSORS (MAKE-RECORD-ACCESSORS NAME-STRING RECORD-FIELDS (IF NAMED (QUOTE (CDR T)) T)))) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (SETF (GETHASH STRUCT-NAME *RECORD-TYPES*) SLOTS) (MULTIPLE-VALUE-BIND (RECORD-TAIL-FORMS RECORD-TAIL-INITS) (PROCESS-RECORD-TAIL RECORD-TAIL) (ADD-EXPORTS (IL:BQUOTE ((DEFUN (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (&KEY (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (SLOT &AUX PAIR) (IF (SETQ PAIR (ASSOC SLOT RECORD-TAIL-INITS :TEST (FUNCTION EQ))) (LIST SLOT (CDR PAIR)) SLOT))) SLOTS))) (IL:\\\, (MAKE-BQ (LET ((FORM (SUBLIS (MAPCAR (FUNCTION (LAMBDA (SLOT) (CONS SLOT (MAKE-MACRO-ARG :ELEMENT SLOT)))) SLOTS) RECORD-FIELDS))) (IF NAMED (CONS RECORD-NAME FORM) FORM))))) (DEFMACRO (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "COPY-" NAME-STRING))) (X) (IL:\\\, (MAKE-BQ (IL:BQUOTE (COPY-TREE (IL:\\\, (MAKE-MACRO-ARG :ELEMENT (QUOTE X)))))))) (IL:\\\,@ ACCESSORS) (IL:\\\,@ RECORD-TAIL-FORMS)))))))
(IL:* IL:\; " ^'(record foo (a b . c) b _ 3) ")
(IL:* IL:|;;|
"
; this version defines a defstruct which is not really the same
; as the IL record type.
(defun
define-record-structure (record-name record-fields named record-tail)
(let* ((name-string (symbol-name record-name))
(struct-name (intern name-string))
(*current-record-name* record-name)
(slots nil))
(declare (special *current-record-name*))
(setq record-fields (make-true-list record-fields))
(do ((fields record-fields (rest fields))
field)
((null fields) (setq slots (nreverse slots)))
(setq field (first fields))
(cond
((null field )
(warn \"NIL as record field name not supported\"))
((atom field) (push field slots))
((eq (first field) '*)) ;Ignore comments
(t (setq slots (append (reverse (flatten field)) slots)))))
(setf (gethash struct-name *record-types*) slots)
(multiple-value-bind
(record-tail-forms record-tail-inits)
(process-record-tail record-tail)
(add-exports
`((defstruct
,struct-name
(:type list)
(:named ,named)
,@(mapcar
#'(lambda (slot &aux pair)
(if (setq pair (assoc slot record-tail-inits))
`(,slot ,(cdr pair))
slot))
slots))
,@record-tail-forms)))))
")
(IL:* IL:|;;|
"Returns two values: a list of forms to be generated, and a list of (slot . init-form) pairs.")
(DEFUN PROCESS-RECORD-TAIL (RECORD-TAIL) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (DO ((SPECS RECORD-TAIL (REST SPECS)) SPEC (FORMS NIL) (INITS NIL)) ((ENDP SPECS) (VALUES FORMS (REVERSE INITS))) (COND ((AND (ATOM (FIRST SPECS)) (REST SPECS) (EQ (SECOND SPECS) (QUOTE IL:_))) (IF (EQ *CURRENT-RECORD-NAME* (FIRST SPECS)) (WARN "implicit CREATE record spec (by assignment to record name) not supported") (PUSH (CONS (FIRST SPECS) (CONVERT (THIRD SPECS))) INITS)) (IL:* IL:|;;| "A \"field-name _ form\" spec is not a list -- it is") (IL:* IL:|;;| "three separate entries in the record-tail.") (POP SPECS) (POP SPECS)) (T (IL:* IL:\; "All others are lists.") (SETQ SPEC (FIRST SPECS)) (CASE (FIRST SPEC) ((IL:CREATE IL:INIT IL:SUBRECORD IL:SYSTEM) (WARN "~:@(~s~) record spec not supported" (FIRST SPEC))) (IL:TYPE? (PUSH (IL:BQUOTE (DEFUN (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME *CURRENT-RECORD-NAME*) "-P"))) (DATUM) (LET ((*LOCALS* (ACONS (QUOTE DATUM) :LOCAL *LOCALS*))) (IL:\\\,@ (MAPCONVERT (REST SPEC)))))) FORMS)) ((IL:ACCESSFNS IL:BLOCKRECORD) (LET ((*ADD-TO-RECORD-DEFN* T)) (DECLARE (SPECIAL *ADD-TO-RECORD-DEFN*)) (SETQ FORMS (APPEND FORMS (LIST (CONVERT SPEC)))))) (T (WARN "unknown record spec ~s ignored" SPEC)))))))
(IL:* IL:|;;|
"Define user-created access functions. It doesn't matter if these fields are part of the structure or not. If so, they will redefine the access functions created by defstruct."
)
(IL-DEFCONV ACCESSFNS (RECORD-NAME &OPTIONAL RECORD-FIELDS &REST RECORD-TAIL) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (DECLARE (SPECIAL *LOCALS*)) (IL:* IL:|;;| "The manual says the record name is the first argument, but it appears that sometimes it is missing when this is a subdeclaration, so we get it from a special variable which is set while processing the main declaration.") (UNLESS (ATOM RECORD-NAME) (SETQ RECORD-FIELDS RECORD-NAME RECORD-NAME *CURRENT-RECORD-NAME*)) (WHEN) (DO ((FORMS NIL) FIELD FIELD-NAME ACCESSOR-NAME (FIELDS (IF (AND (= (LENGTH RECORD-FIELDS) 2) (ATOM (FIRST RECORD-FIELDS))) (IL:* IL:|;;| "Pidgin single accessfn declaration...") (LIST RECORD-FIELDS) RECORD-FIELDS) (REST FIELDS))) ((ENDP FIELDS) (ADD-EXPORTS (REVERSE FORMS))) (SETQ FIELD (FIRST FIELDS)) (SETQ FIELD-NAME (POP FIELD)) (SETQ ACCESSOR-NAME (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-NAME) "-" (SYMBOL-NAME FIELD-NAME)))) (IL:* IL:\; "Define the accessor function") (WHEN FIELD (IL:* IL:|;;| "Also remember that we know about this field") (PUSH FIELD-NAME (GETHASH RECORD-NAME *RECORD-TYPES*)) (PUSH (IL:BQUOTE (DEFUN (IL:\\\, ACCESSOR-NAME) (DATUM) (IL:\\\, (LET ((*LOCALS* (ACONS (QUOTE DATUM) :LOCAL *LOCALS*))) (CONVERT (POP FIELD)))))) FORMS) (IL:* IL:\; "Define the function to set a new value") (WHEN FIELD (PUSH (IL:BQUOTE (DEFSETF (IL:\\\, ACCESSOR-NAME) (DATUM) (NEWVALUE) (IL:\\\, (LET ((*LOCALS* (ACONS (QUOTE NEWVALUE) :LOCAL (ACONS (QUOTE DATUM) :LOCAL *LOCALS*)))) (CONVERT (POP FIELD)))))) FORMS)))))
(IL:* IL:|;;| " (convert '(accessfns pilotbbt ((pbtsource foo1 foo2))))")
(IL-DEFCONV DATATYPE (RECORD-NAME RECORD-FIELDS &REST RECORD-TAIL) (LET* ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (STRUCT-NAME (INTERN NAME-STRING)) (*CURRENT-RECORD-NAME* RECORD-NAME) RECORD-TAIL-FORMS RECORD-TAIL-INITS (SLOTS NIL) (SLOT-DEFNS NIL) (FIELD-TYPES NIL)) (DECLARE (SPECIAL *CURRENT-RECORD-NAME*)) (DO ((FIELDS RECORD-FIELDS (REST FIELDS)) SLOT-NAME FIELD-TYPE FIELD) ((ENDP FIELDS) (SETQ SLOTS (NREVERSE SLOTS))) (SETQ FIELD (FIRST FIELDS)) (SETQ SLOT-NAME (COND ((CONSP FIELD) (CASE (FIRST FIELD) ((NIL) (IL:* IL:|;;| "Some code has field specs like \"(nil 5 word))\"") (WARN "record spec ~s ignored -- NIL not allowed as field name" FIELD) NIL) (IL:* NIL) (IL:* IL:\; "Ignore comments") (T (SETQ FIELD-TYPE (REST FIELD)) (FIRST FIELD)))) (T (SETQ FIELD-TYPE NIL) FIELD))) (WHEN SLOT-NAME (PUSH SLOT-NAME SLOTS) (PUSH FIELD-TYPE FIELD-TYPES))) (IL:* IL:|;;| "Have to set the field names defined here before calling") (IL:* IL:|;;| "process-record-tail since it will add to them.") (SETF (GETHASH STRUCT-NAME *RECORD-TYPES*) SLOTS) (MULTIPLE-VALUE-SETQ (RECORD-TAIL-FORMS RECORD-TAIL-INITS) (PROCESS-RECORD-TAIL RECORD-TAIL)) (IL:* IL:|;;| "This could be changed to a mapcar. Previous definitions of il-defconv") (IL:* IL:|;;| "for some reason did not correctly handle lambda's.") (DO ((SLOTS SLOTS (REST SLOTS)) (FIELD-TYPES FIELD-TYPES (REST FIELD-TYPES)) SLOT-NAME FIELD-TYPE) ((ENDP SLOTS) (SETQ SLOT-DEFNS (NREVERSE SLOT-DEFNS))) (SETQ SLOT-NAME (FIRST SLOTS) FIELD-TYPE (FIRST FIELD-TYPES)) (PUSH (IL:BQUOTE ((IL:\\\, SLOT-NAME) (IL:\\\, (CDR (ASSOC SLOT-NAME RECORD-TAIL-INITS))) :TYPE (IL:\\\, (FIELD-TO-SLOT-TYPE FIELD-TYPE SLOT-NAME)))) SLOT-DEFNS)) (LET ((NAME-STRING (SYMBOL-NAME STRUCT-NAME))) (PROGN-IF-NEEDED (IL:BQUOTE ((EXPORT (QUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "COPY-" NAME-STRING))) (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-P"))) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (SLOT) (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME SLOT))))) SLOTS))))) (DEFSTRUCT (IL:\\\, STRUCT-NAME) (IL:\\\,@ SLOT-DEFNS)) (IL:\\\,@ RECORD-TAIL-FORMS)))))))
(DEFUN FIELD-TO-SLOT-TYPE (TYPE &OPTIONAL SLOT-NAME) (IF (NULL TYPE) T (CASE (FIRST TYPE) (INTEGER (QUOTE INTEGER)) ((IL:FIXP IL:SIGNEDWORD) (QUOTE FIXNUM)) ((IL:FLOATING IL:FLOATP) (QUOTE FLOAT)) (IL:FLAG (QUOTE (OR NIL T))) (IL:BITS (IF (<= (1- (EXPT 2 (SECOND TYPE))) MOST-POSITIVE-FIXNUM) (QUOTE FIXNUM) (QUOTE INTEGER))) (BYTE (QUOTE FIXNUM)) (IL:WORD (QUOTE FIXNUM)) ((IL:POINTER IL:XPOINTER IL:FULLPOINTER IL:FULLXPOINTER) T) (T (WARN "Unknown type spec ~:@(~a~)~:[~; for slot ~:*~:@(~a~)~]" (FIRST TYPE) SLOT-NAME) T))))
(IL-DEFCONV /DECLAREDATATYPE (&REST ARGS) (WARN "/DECLAREDATATYPE ignored") NIL)
(DEFUN FIND-RECORD-TYPE (FIELDNAME) (LET ((RECORD-TYPES NIL)) (MAPHASH (FUNCTION (LAMBDA (RECORD-NAME FIELDS) (WHEN (MEMBER FIELDNAME FIELDS :TEST (FUNCTION EQ)) (PUSH RECORD-NAME RECORD-TYPES)))) *RECORD-TYPES*) (CASE (LENGTH RECORD-TYPES) (0 (WARN "no record is defined with a field named ~s, using a dummy function XXXXX-~a" FIELDNAME FIELDNAME) (QUOTE XXXXX)) (1 (CAR RECORD-TYPES)) (T (CERROR "use ~a" "~*multiple record types have a field named ~s: ~s" (CAR RECORD-TYPES) FIELDNAME RECORD-TYPES) (CAR RECORD-TYPES)))))
(DEFUN FIND-RECORD-FIELDS (RECORD-TYPE) (MULTIPLE-VALUE-BIND (RECORD FOUND) (GETHASH RECORD-TYPE *RECORD-TYPES*) (IF FOUND RECORD (PROGN (WARN "no record type ~a, initializations may not be done" RECORD-TYPE) NIL))))
(IL-DEFCONV |fetch| (FIELD-NAME OF &OPTIONAL X &AUX RECORD-TYPE) (DECLARE (SPECIAL IL:USERRECLST)) (WHEN (NOT (STRING-EQUAL OF "of")) (SETQ X OF)) (IF (CONSP FIELD-NAME) (SETQ RECORD-TYPE (FIRST FIELD-NAME) FIELD-NAME (SECOND FIELD-NAME)) (LET ((M (IL:\\RECORDBLOCK/RECFIELDLOOK IL:USERRECLST FIELD-NAME))) (UNLESS M (WARN "no record is defined with a field named ~s, using a dummy function XXXXX-~a" FIELD-NAME FIELD-NAME)) (UNLESS (NULL (CDR M)) (ERROR "More than one record with ~:@(~a~)." FIELD-NAME)) (SETQ RECORD-TYPE (IF (NULL M) (QUOTE XXXXX) (SECOND (FIRST M)))))) (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-TYPE) "-" (SYMBOL-NAME FIELD-NAME)))) (IL:\\\, (CONVERT X)))))
(IL-DEFCONV |replace| (FIELD-NAME OF X WITH Y &AUX RECORD-TYPE) (COND ((NOT (STRING-EQUAL OF "OF")) (CERROR "Skip this form" "Missing |of| in |replace|") *CURRENT-FORM*) ((NOT (STRING-EQUAL WITH "WITH")) (CERROR "Skip this form" "Missing |with| in |replace|") *CURRENT-FORM*) (T (IF (CONSP FIELD-NAME) (SETQ RECORD-TYPE (FIRST FIELD-NAME) FIELD-NAME (SECOND FIELD-NAME)) (LET ((M (IL:\\RECORDBLOCK/ACCESSDEF FIELD-NAME))) (UNLESS M (WARN "no record is defined with a field named ~s, using a dummy function XXXXX-~a" FIELD-NAME FIELD-NAME)) (UNLESS (NULL (CDR M)) (ERROR "More than one record with ~:@(~a~)." FIELD-NAME)) (SETQ RECORD-TYPE (IF (NULL M) (QUOTE XXXXX) (SECOND (FIRST M)))))) (IL:BQUOTE (SETF ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-TYPE) "-" (SYMBOL-NAME FIELD-NAME)))) (IL:\\\, (CONVERT X))) (IL:\\\, (CONVERT Y)))))))
(IL-DEFCONV TYPE? (RECORD-NAME FORM) (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) (SYMBOL-NAME RECORD-NAME) "-P"))) (IL:\\\, (CONVERT FORM)))))
(IL-DEFCONV |create| (RECORD-NAME &REST ASSIGNMENTS) (|DO-create| RECORD-NAME ASSIGNMENTS))
(DEFUN |DO-create| (RECORD-NAME ASSIGNMENTS) (LET ((NAME-STRING (SYMBOL-NAME RECORD-NAME)) (INITS NIL) (SMASHING NIL) (USING NIL) (VAR (MAKE-FAKE-SYMBOL (STRING (GENSYM "G"))))) (DO ((ASSIGNMENTS ASSIGNMENTS (REST ASSIGNMENTS))) ((ENDP ASSIGNMENTS) (SETQ INITS (REVERSE INITS))) (COND ((AND (CONSP (FIRST ASSIGNMENTS)) (STRING-EQUAL (CAAR ASSIGNMENTS) (QUOTE "*")))) ((AND (SYMBOLP (SECOND ASSIGNMENTS)) (STRING-EQUAL (SECOND ASSIGNMENTS) "_")) (PUSH (CONS (FIRST ASSIGNMENTS) (CONVERT (THIRD ASSIGNMENTS))) INITS) (SETQ ASSIGNMENTS (CDDR ASSIGNMENTS))) (T (CASE (FIRST ASSIGNMENTS) ((IL:USING IL:|using|) (SETQ USING (CONVERT (SECOND ASSIGNMENTS)))) ((IL:COPYING IL:|copying|) (WARN "COPYING assignment not supported")) ((IL:REUSING IL:|reusing|) (WARN "REUSING assignment not supported")) ((IL:SMASHING IL:|smashing|) (SETQ SMASHING (CONVERT (SECOND ASSIGNMENTS)))) (T (WARN "unknown assignment ~s" (FIRST ASSIGNMENTS)))) (POP ASSIGNMENTS)))) (COND (USING (IL:BQUOTE (LET (((IL:\\\, VAR) ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "COPY-" NAME-STRING))) (IL:\\\, USING)))) (SETF (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (INIT) (LIST (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME (CAR INIT))))) (IL:\\\, VAR))) (CDR INIT)))) INITS))) (IL:\\\, VAR)))) (SMASHING (IF INITS (IL:BQUOTE (LET (((IL:\\\, VAR) (IL:\\\, SMASHING))) (SETF (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (INIT) (LIST (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-" (SYMBOL-NAME (CAR INIT))))) (IL:\\\, VAR))) (CDR INIT)))) INITS))) (IL:\\\, VAR))) SMASHING)) (T (IL:BQUOTE ((IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) "MAKE-" NAME-STRING))) (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (INIT) (IL:BQUOTE ((IL:\\\, (INTERN (STRING (CAR INIT)) (QUOTE KEYWORD))) (IL:\\\, (CDR INIT)))))) INITS))))))))
(IL-COPYCONV |fetch| FETCH)
(IL-COPYCONV |fetch| |ffetch|)
(IL-COPYCONV |ffetch| FFETCH)
(IL-COPYCONV |replace| REPLACE)
(IL-COPYCONV |replace| |freplace|)
(IL-COPYCONV |freplace| FREPLACE)
(IL-COPYCONV TYPE? |type?|)
(IL-COPYCONV |create| CREATE)
(IL:PUTPROPS IL:IL-RECORD IL:MAKEFILE-ENVIRONMENT (:PACKAGE "IL-CONVERT" :READTABLE "XCL"))
(IL:PUTPROPS IL:IL-RECORD IL:COPYRIGHT ("ENVOS Corporation" 1989))
(IL:DECLARE\: IL:DONTCOPY
(IL:FILEMAP (NIL)))
IL:STOP

1
lispusers/MIGRATION/IL-RECORD.LCOM Normal file
View File

File diff suppressed because one or more lines are too long

1356
lispusers/MIGRATION/IL-SIM Normal file
View File

File diff suppressed because one or more lines are too long

1
lispusers/MIGRATION/IL-SIM.LCOM Normal file
View File

File diff suppressed because one or more lines are too long

90
lispusers/MIGRATION/IL-STARTUP Normal file
View File

@ -0,0 +1,90 @@
(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (CLIN-PACKAGE "IL-CONVERT")
*PACKAGE*) BASE 10)
(IL:FILECREATED "14-Sep-89 10:01:13" IL:|{DSK}/python2/aria/migration/interlisp/IL-STARTUP.;2| 6548
IL:|changes| IL:|to:| (IL:FUNCTIONS NOTE-EXPORTED-SYMBOL CONVERT)
IL:|previous| IL:|date:| " 7-Jul-89 16:55:06" IL:|{DSK}/users/eweaver/convert/IL-STARTUP.;17|
)
; Copyright (c) 1989 by ENVOS Corporation. All rights reserved.
(IL:PRETTYCOMPRINT IL:IL-STARTUPCOMS)
(IL:RPAQQ IL:IL-STARTUPCOMS ((IL:* IL:|;;;| "This should be loaded before any other files.") (EVAL-WHEN (LOAD COMPILE EVAL) (IL:VARIABLES *IL-PACKAGE*)) (IL:VARIABLES *IL-SIM-PACKAGE*) (IL:* IL:|;;;| "This funny stuff is for printing backquote forms. ") (IL:STRUCTURES BQ MACRO-ARG) (IL:* IL:|;;;| "") (IL:VARIABLES *CURRENT-CONVERT-FORM* *CURRENT-CONVERT-FUNCTION* *GLOBALS* *LOCALS* *FUNCTION-CALLS* *CURRENT-FUNCTION-CALLS* *CURRENT-FREE-REFERENCES* *EXPORTED-IL-SYMBOLS*) (IL:P (EXPORT (QUOTE CONVERT))) (IL:FUNCTIONS CONVERT MAPCONVERT EXTERN NOTE-EXPORTED-SYMBOL) (IL:FUNCTIONS TRUE-LIST-P) (IL:* IL:\; "true if this is nil or a true list") (IL:* IL:|;;| "make a true list out of a pseudo-list (make-true-list '(A B . C)) => (A B C)") (IL:FUNCTIONS MAKE-TRUE-LIST) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IL-STARTUP))
)
(IL:* IL:|;;;| "This should be loaded before any other files.")
(EVAL-WHEN (LOAD COMPILE EVAL)
(DEFVAR *IL-PACKAGE* (FIND-PACKAGE "INTERLISP"))
)
(DEFVAR *IL-SIM-PACKAGE* (MAKE-PACKAGE "IL-SIM" :USE NIL))
(IL:* IL:|;;;| "This funny stuff is for printing backquote forms. ")
(DEFSTRUCT (BQ (:TYPE LIST) (:CONSTRUCTOR MAKE-BQ (ELEMENT))) (BQFLAG (QUOTE IL:BQUOTE)) ELEMENT)
(DEFSTRUCT (MACRO-ARG (:TYPE LIST) (:CONSTRUCTOR MAKE-MACRO-ARG (&KEY ELEMENT APPEND-P (FLAG (IF APPEND-P (QUOTE IL:\\\,@) (QUOTE IL:\\\,)))))) FLAG ELEMENT)
(IL:* IL:|;;;| "")
(DEFVAR *CURRENT-CONVERT-FORM*)
(DEFVAR *CURRENT-CONVERT-FUNCTION*)
(DEFVAR *GLOBALS* NIL)
(DEFVAR *LOCALS* NIL)
(DEFVAR *FUNCTION-CALLS* NIL)
(DEFVAR *CURRENT-FUNCTION-CALLS* NIL)
(DEFVAR *CURRENT-FREE-REFERENCES* NIL)
(DEFVAR *EXPORTED-IL-SYMBOLS* NIL)
(EXPORT (QUOTE CONVERT))
(DEFUN CONVERT (FORM &AUX FN VAR) (IL:BLOCK) (LET ((*CURRENT-EXPRESSION* FORM)) (COND (IL:* IL:|;;| "Forms in which the car is a symbol...") ((AND (CONSP FORM) (ATOM (FIRST FORM))) (COND ((NOT (TRUE-LIST-P FORM)) (LET ((TAIL (CDR (LAST FORM)))) (IL:* IL:|;;| "dotted lists ending in a macro arg are okay.") (IF (AND (SYMBOLP TAIL) (EQ (CDR (ASSOC TAIL *LOCALS*)) :MACRO-ARG)) (LET ((MARG (MAKE-MACRO-ARG :ELEMENT TAIL)) (VAL (COPY-LIST FORM))) (SETF (CDR (LAST VAL)) MARG) VAL) (PROGN (WARN "~s not a list, left as is" FORM) FORM)))) ((LET ((FOO (GET (CAR FORM) (QUOTE IL:CLISPWORD)))) (AND (CONSP FOO) (EQ (CAR FOO) (QUOTE IL:FORWORD)) (NOT (EQ (CAR FORM) (QUOTE DECLARE))))) (CONVERT-ITERATION-STATEMENT (CAR FORM) (CDR FORM))) ((SETQ FN (GET (FIRST FORM) (QUOTE CONVERT-FORM))) (SETQ *CURRENT-CONVERT-FORM* FORM *CURRENT-CONVERT-FUNCTION* FN) (APPLY FN (REST FORM))) ((OR (MACRO-FUNCTION (FIRST FORM)) (SPECIAL-FORM-P (FIRST FORM))) (IL:* IL:|;;| "Use CL code walker for this") (WALK-FORM-INTERNAL FORM)) ((EQ (CHAR (STRING (FIRST FORM)) 0) #\\) (WARN "Untranslatable function ~a" (STRING (FIRST FORM))) FORM) (T (IL:* IL:|;;| "(setq fn (first form) (extern (symbol-name (first form)) *il-package*))") (WHEN *CURRENT-FUNCTION-CALLS* (PUSHNEW FN *CURRENT-FUNCTION-CALLS*)) (NOTE-EXPORTED-SYMBOL (FIRST FORM)) (CONS (FIRST FORM) (MAPCAR (QUOTE CONVERT) (REST FORM)))))) (IL:* IL:|;;| "Forms in which the car is a Lambda...") ((AND (CONSP FORM) (IL:* IL:|;;| "But car is cons") (SYMBOLP (CAAR FORM)) (STRING-EQUAL (CAAR FORM) "LAMBDA")) (CONS (CONVERT (CAR FORM)) (MAPCONVERT (CDR FORM)))) (IL:* IL:|;;| "Other non-atomic forms...") ((CONSP FORM) (WARN "Unknown kind of form ~s, not converted." FORM) FORM) (IL:* IL:|;;| "Atomic forms...") ((NULL FORM) NIL) ((EQ FORM T) T) ((KEYWORDP FORM) FORM) ((SYMBOLP FORM) (IF (SETQ VAR (ASSOC FORM *LOCALS*)) (CASE (CDR VAR) (:LOCAL (CAR VAR)) (:MACRO-ARG (MAKE-MACRO-ARG :ELEMENT (CAR VAR))) (T (ERROR "unexpected value ~s in *LOCALS*" VAR))) (PROGN (NOTE-EXPORTED-SYMBOL FORM) (WHEN *CURRENT-FREE-REFERENCES* (PUSHNEW FORM *CURRENT-FREE-REFERENCES*)) FORM))) (T FORM))))
(DEFUN MAPCONVERT (FORM-OR-FORMS) (IF (ATOM FORM-OR-FORMS) (CONVERT FORM-OR-FORMS) (DO* ((TAIL FORM-OR-FORMS (CDR TAIL)) (SUBFORM (IF (CONSP TAIL) (CAR TAIL) TAIL) (IF (CONSP TAIL) (CAR TAIL) TAIL)) RESULT) ((ATOM TAIL) (IF (NULL TAIL) (NREVERSE RESULT) (PROGN (SETF (CDR (LAST (SETQ RESULT (NREVERSE RESULT)))) (CONVERT TAIL)) RESULT))) (PUSH (CONVERT SUBFORM) RESULT))))
(DEFUN EXTERN (STRING &OPTIONAL (PACKAGE *PACKAGE*)) (IL:* (LET ((SYM (INTERN STRING PACKAGE))) (EXPORT SYM PACKAGE) (IF (EQ PACKAGE *IL-PACKAGE*) (PUSHNEW SYM *EXPORTED-IL-SYMBOLS*)) SYM)) (ERROR "Old leftover call to EXTERN!"))
(DEFUN NOTE-EXPORTED-SYMBOL (SYM &AUX PKG PKGNM) "" (WHEN (NULL (SETQ PKG (SYMBOL-PACKAGE SYM))) (RETURN-FROM NOTE-EXPORTED-SYMBOL SYM)) (WHEN (AND (EQ PKG IL:*INTERLISP-PACKAGE*) (NOT (EQ (FIND-SYMBOL (SYMBOL-NAME SYM) IL:*LISP-PACKAGE*) SYM)) (OR *WARN-FOR-ALL-IL-SYMBOLS* (< (IL:\\LOLOC SYM) (IL:\\LOLOC *WARN-FOR-IL-SYMBOLS-LOWER-THAN-THIS*)))) (LET ((*CURRENT-EXPRESSION* SYM)) (WARN "Use of IL symbol ~a" SYM))) (WHEN (OR (EQ PKG IL:*INTERLISP-PACKAGE*) (AND (NOT (OR (EQ PKG IL:*KEYWORD-PACKAGE*) (EQ PKG IL:*LISP-PACKAGE*))) (MULTIPLE-VALUE-BIND (IGNORE TYPE) (FIND-SYMBOL (SYMBOL-NAME SYM) PKG) (EQ TYPE :EXTERNAL)))) (IF (NULL *FILE-CONTEXT*) (PUSHNEW SYM *EXPORTED-IL-SYMBOLS*) (PUSHNEW SYM (FILE-CONTEXT-EXPORTED-SYMS *FILE-CONTEXT*)))) SYM)
(DEFUN TRUE-LIST-P (PSEUDO-LIST) (DO ((PL PSEUDO-LIST (CDR PL))) ((NULL PL) T) (IF (ATOM PL) (RETURN NIL))))
(IL:* IL:\; "true if this is nil or a true list")
(IL:* IL:|;;| "make a true list out of a pseudo-list (make-true-list '(A B . C)) => (A B C)")
(DEFUN MAKE-TRUE-LIST (PSEUDO-LIST) (COND ((TRUE-LIST-P PSEUDO-LIST) PSEUDO-LIST) (T (DO ((TRUE-LIST NIL)) ((ATOM PSEUDO-LIST) (NREVERSE (CONS PSEUDO-LIST TRUE-LIST))) (IF (ENDP PSEUDO-LIST) (RETURN (NREVERSE TRUE-LIST))) (PUSH (POP PSEUDO-LIST) TRUE-LIST)))))
(IL:PUTPROPS IL:IL-STARTUP IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (IN-PACKAGE "IL-CONVERT") *PACKAGE*) :BASE 10)
)
(IL:PUTPROPS IL:IL-STARTUP IL:FILETYPE :COMPILE-FILE)
(IL:PUTPROPS IL:IL-STARTUP IL:COPYRIGHT ("ENVOS Corporation" 1989))
(IL:DECLARE\: IL:DONTCOPY
(IL:FILEMAP (NIL)))
IL:STOP

1
lispusers/MIGRATION/IL-STARTUP.LCOM Normal file
View File

File diff suppressed because one or more lines are too long

25
lispusers/MIGRATION/MIGRATION-TOOL Normal file
View File

@ -0,0 +1,25 @@
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "IL-CONVERT") READTABLE "XCL")
(IL:FILECREATED "26-Jan-90 10:27:59" IL:|{DSK}/users/welch/migration/MIGRATION-TOOL.;2| 1091
IL:|changes| IL:|to:| (IL:FILES IL:IL-CONVERT)
IL:|previous| IL:|date:| "11-Aug-89 16:19:28" IL:|{DSK}/users/welch/migration/MIGRATION-TOOL.;1|
)
; Copyright (c) 1989, 1990 by ENVOS Corporation. All rights reserved.
(IL:PRETTYCOMPRINT IL:MIGRATION-TOOLCOMS)
(IL:RPAQQ IL:MIGRATION-TOOLCOMS ((IL:PROP IL:MAKEFILE-ENVIRONMENT IL:MIGRATION-TOOL)
(IL:FILES IL:IL-STARTUP IL:IL-CONVERT IL:IL-SIM IL:IL-RECORD
IL:TRANSLATOR-ASSISTANT)))
(IL:PUTPROPS IL:MIGRATION-TOOL IL:MAKEFILE-ENVIRONMENT (:PACKAGE (XCL:DEFPACKAGE "IL-CONVERT")
:READTABLE "XCL"))
(IL:FILESLOAD IL:IL-STARTUP IL:IL-CONVERT IL:IL-SIM IL:IL-RECORD IL:TRANSLATOR-ASSISTANT)
(IL:PUTPROPS IL:MIGRATION-TOOL IL:COPYRIGHT ("ENVOS Corporation" 1989 1990))
(IL:DECLARE\: IL:DONTCOPY
(IL:FILEMAP (NIL)))
IL:STOP

1
lispusers/MIGRATION/MIGRATION-TOOL.LCOM Normal file
View File

@ -0,0 +1 @@
(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "IL-CONVERT") READTABLE "XCL") (IL:FILECREATED "19-Jan-93 19:56:49" ("compiled on " IL:|{DSK}<usr>local>src>tape>MIGRATION>MIGRATION-TOOL.;1|) "11-Jul-91 21:52:09" IL:|bcompl'd| IL:|in| "Lispcore 11-Jul-91 ..." IL:|dated| "11-Jul-91 21:57:45") (IL:FILECREATED "26-Jan-90 10:27:59" IL:|{DSK}/users/welch/migration/MIGRATION-TOOL.;2| 1091 IL:|changes| IL:|to:| (IL:FILES IL:IL-CONVERT) IL:|previous| IL:|date:| "11-Aug-89 16:19:28" IL:|{DSK}/users/welch/migration/MIGRATION-TOOL.;1|) (IL:PRETTYCOMPRINT IL:MIGRATION-TOOLCOMS) (IL:RPAQQ IL:MIGRATION-TOOLCOMS ((IL:PROP IL:MAKEFILE-ENVIRONMENT IL:MIGRATION-TOOL) (IL:FILES IL:IL-STARTUP IL:IL-CONVERT IL:IL-SIM IL:IL-RECORD IL:TRANSLATOR-ASSISTANT))) (IL:PUTPROPS IL:MIGRATION-TOOL IL:MAKEFILE-ENVIRONMENT (:PACKAGE (XCL:DEFPACKAGE "IL-CONVERT") :READTABLE "XCL")) (IL:FILESLOAD IL:IL-STARTUP IL:IL-CONVERT IL:IL-SIM IL:IL-RECORD IL:TRANSLATOR-ASSISTANT) (IL:PUTPROPS IL:MIGRATION-TOOL IL:COPYRIGHT ("ENVOS Corporation" 1989 1990)) NIL

242
lispusers/MIGRATION/SEDIT-DECLS Normal file
View File

File diff suppressed because one or more lines are too long

1
lispusers/MIGRATION/SEDIT-DECLS.LCOM Normal file
View File

File diff suppressed because one or more lines are too long

35
lispusers/MIGRATION/TABLEBROWSERDECLS Normal file
View File

@ -0,0 +1,35 @@
(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP")
(FILECREATED "27-Jan-88 17:04:01" {ERIS}<LISPCORE>LIBRARY>TABLEBROWSERDECLS.;5 5052
changes to%: (RECORDS TABLEBROWSER)
previous date%: "18-Oct-85 18:10:50" {ERIS}<LISPCORE>LIBRARY>TABLEBROWSERDECLS.;2)
(* "
Copyright (c) 1985, 1988 by Xerox Corporation. All rights reserved.
")
(PRETTYCOMPRINT TABLEBROWSERDECLSCOMS)
(RPAQQ TABLEBROWSERDECLSCOMS ((RECORDS TABLEBROWSER TABLEITEM) (CONSTANTS TB.LEFT.MARGIN)))
(DECLARE%: EVAL@COMPILE
(DATATYPE TABLEBROWSER ((TBREADY FLAG) (TBHEIGHTEXPLICIT FLAG) (* ; "True if creator set explicit item height or baseline") (NIL 6 FLAG) (TBITEMS POINTER) (* ; "List of items in this browser") (TB#ITEMS WORD) (* ; "Number of items") (TB#DELETED WORD) (* ; "Number of items marked deleted") (TB#LINESPERITEM WORD) (* ; "Number of lines occupied by each item, normally 1 (dunno if any other values work)") (TBFIRSTSELECTEDITEM WORD) (* ; "Number of first selected item. If none selected, is > TB#ITEMS") (TBLASTSELECTEDITEM WORD) (* ; "Number of last selected item. If none selected, is 0") (TBITEMHEIGHT WORD) (* ; "Height of an item, i.e., fontheight*linesperitem") (TBMAXXPOS WORD) (* ; "The largest x-position a user printfn has printed to") (TBFONTHEIGHT WORD) (* ; "Height, ascent, descent of font") (TBFONTASCENT WORD) (TBBASELINE WORD) (TBWINDOW POINTER) (* ; "Pointer to the display window. Need to snap this link when browser is closed") (TBLOCK POINTER) (* ; "Monitor lock guarding some browser operations") (TBUSERDATA POINTER) (* ; "Arbitrary user storage") (TBFONT POINTER) (* ; "Pointer to font used by display") (TBEXTENT POINTER) (* ; "Window's extent, updated as items are added, deleted, or printfn prints farther to right") (TBUPDATEFROMHERE POINTER) (* ; "If changes have occurred while shrunk, this gives the # of first item that needs redisplay") (TBCOLUMNS POINTER) (* ; "Number of columns--not yet implemented") (TBPRINTFN POINTER) (* ; "(Browser Item Window) -- displays Item at current line position in window") (TBCOPYFN POINTER) (* ; "(Browser Item) -- copy selects Item") (TBFONTCHANGEFN POINTER) (* ; "(Browser Window) -- called when tb.set.font changes the font") (TBCLOSEFN POINTER) (* ; "(Browser Window Close/Shrink) -- called when you try to close or shrink window") (TBAFTERCLOSEFN POINTER) (* ; "(Browser Window) -- called to cleanup AFTER a closew") (TBTITLEEVENTFN POINTER) (* ; "(Window Browser) -- handles button event in browser's title") (TBLINETHICKNESS POINTER) (* ; "Thickness of line for deletions (normally 1)") (TBORIGIN POINTER) (* ; "Y position of the top of the first item") (TBTAILHINT POINTER) (* ; "A tail of TBITEMS, used to speed up TB.NTH.ITEM") (TBHEADINGWINDOW POINTER) (* ; "An optional %"header window%" that should be horizontally scrolled in synchrony with this one") (NIL POINTER))
)
(DATATYPE TABLEITEM ((TISELECTED FLAG) (TIDELETED FLAG) (TIUNDELETABLE FLAG) (TIUNSELECTABLE FLAG) (TIUNCOPYSELECTABLE FLAG) (NIL 3 FLAG) (TIDATA POINTER) (TI# WORD) (NIL WORD))
)
)
(/DECLAREDATATYPE (QUOTE TABLEBROWSER) (QUOTE (FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD WORD WORD WORD WORD WORD WORD WORD WORD POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER)) (QUOTE ((TABLEBROWSER 0 (FLAGBITS . 0)) (TABLEBROWSER 0 (FLAGBITS . 16)) (TABLEBROWSER 0 (FLAGBITS . 32)) (TABLEBROWSER 0 (FLAGBITS . 48)) (TABLEBROWSER 0 (FLAGBITS . 64)) (TABLEBROWSER 0 (FLAGBITS . 80)) (TABLEBROWSER 0 (FLAGBITS . 96)) (TABLEBROWSER 0 (FLAGBITS . 112)) (TABLEBROWSER 0 POINTER) (TABLEBROWSER 2 (BITS . 15)) (TABLEBROWSER 3 (BITS . 15)) (TABLEBROWSER 4 (BITS . 15)) (TABLEBROWSER 5 (BITS . 15)) (TABLEBROWSER 6 (BITS . 15)) (TABLEBROWSER 7 (BITS . 15)) (TABLEBROWSER 8 (BITS . 15)) (TABLEBROWSER 9 (BITS . 15)) (TABLEBROWSER 10 (BITS . 15)) (TABLEBROWSER 11 (BITS . 15)) (TABLEBROWSER 12 POINTER) (TABLEBROWSER 14 POINTER) (TABLEBROWSER 16 POINTER) (TABLEBROWSER 18 POINTER) (TABLEBROWSER 20 POINTER) (TABLEBROWSER 22 POINTER) (TABLEBROWSER 24 POINTER) (TABLEBROWSER 26 POINTER) (TABLEBROWSER 28 POINTER) (TABLEBROWSER 30 POINTER) (TABLEBROWSER 32 POINTER) (TABLEBROWSER 34 POINTER) (TABLEBROWSER 36 POINTER) (TABLEBROWSER 38 POINTER) (TABLEBROWSER 40 POINTER) (TABLEBROWSER 42 POINTER) (TABLEBROWSER 44 POINTER) (TABLEBROWSER 46 POINTER))) (QUOTE 48))
(/DECLAREDATATYPE (QUOTE TABLEITEM) (QUOTE (FLAG FLAG FLAG FLAG FLAG FLAG FLAG FLAG POINTER WORD WORD)) (QUOTE ((TABLEITEM 0 (FLAGBITS . 0)) (TABLEITEM 0 (FLAGBITS . 16)) (TABLEITEM 0 (FLAGBITS . 32)) (TABLEITEM 0 (FLAGBITS . 48)) (TABLEITEM 0 (FLAGBITS . 64)) (TABLEITEM 0 (FLAGBITS . 80)) (TABLEITEM 0 (FLAGBITS . 96)) (TABLEITEM 0 (FLAGBITS . 112)) (TABLEITEM 0 POINTER) (TABLEITEM 2 (BITS . 15)) (TABLEITEM 3 (BITS . 15)))) (QUOTE 4))
(DECLARE%: EVAL@COMPILE
(RPAQQ TB.LEFT.MARGIN 8)
(CONSTANTS TB.LEFT.MARGIN)
)
(PUTPROPS TABLEBROWSERDECLS COPYRIGHT ("Xerox Corporation" 1985 1988))
(DECLARE%: DONTCOPY
(FILEMAP (NIL)))
STOP

1
lispusers/MIGRATION/TABLEBROWSERDECLS.LCOM Normal file
View File

File diff suppressed because one or more lines are too long

1646
lispusers/MIGRATION/TRANSLATOR-ASSISTANT Normal file
View File

File diff suppressed because it is too large Load Diff