From 3d8066b7e82d9597e1ee8342bb1b744e837d1d97 Mon Sep 17 00:00:00 2001 From: Arun Welch Date: Sun, 28 Nov 2021 23:07:37 -0700 Subject: [PATCH] Migration from Interlisp to CL format (#591) Tool for translating File Manager format files to Common Lisp format --- lispusers/MIGRATION/DIR.TXT | 3 + lispusers/MIGRATION/FILEPKGRECORDS | 116 ++ lispusers/MIGRATION/FILEPKGRECORDS.LCOM | 1 + lispusers/MIGRATION/IL-CONVERT | 805 ++++++++++ lispusers/MIGRATION/IL-CONVERT.LCOM | 1 + lispusers/MIGRATION/IL-LOOPS | 420 +++++ lispusers/MIGRATION/IL-LOOPS.LCOM | 1 + lispusers/MIGRATION/IL-RECORD | 214 +++ lispusers/MIGRATION/IL-RECORD.LCOM | 1 + lispusers/MIGRATION/IL-SIM | 1356 ++++++++++++++++ lispusers/MIGRATION/IL-SIM.LCOM | 1 + lispusers/MIGRATION/IL-STARTUP | 90 ++ lispusers/MIGRATION/IL-STARTUP.LCOM | 1 + lispusers/MIGRATION/MIGRATION-TOOL | 25 + lispusers/MIGRATION/MIGRATION-TOOL.LCOM | 1 + lispusers/MIGRATION/SEDIT-DECLS | 242 +++ lispusers/MIGRATION/SEDIT-DECLS.LCOM | 1 + lispusers/MIGRATION/TABLEBROWSERDECLS | 35 + lispusers/MIGRATION/TABLEBROWSERDECLS.LCOM | 1 + lispusers/MIGRATION/TRANSLATOR-ASSISTANT | 1646 ++++++++++++++++++++ 20 files changed, 4961 insertions(+) create mode 100644 lispusers/MIGRATION/DIR.TXT create mode 100644 lispusers/MIGRATION/FILEPKGRECORDS create mode 100644 lispusers/MIGRATION/FILEPKGRECORDS.LCOM create mode 100644 lispusers/MIGRATION/IL-CONVERT create mode 100644 lispusers/MIGRATION/IL-CONVERT.LCOM create mode 100644 lispusers/MIGRATION/IL-LOOPS create mode 100644 lispusers/MIGRATION/IL-LOOPS.LCOM create mode 100644 lispusers/MIGRATION/IL-RECORD create mode 100644 lispusers/MIGRATION/IL-RECORD.LCOM create mode 100644 lispusers/MIGRATION/IL-SIM create mode 100644 lispusers/MIGRATION/IL-SIM.LCOM create mode 100644 lispusers/MIGRATION/IL-STARTUP create mode 100644 lispusers/MIGRATION/IL-STARTUP.LCOM create mode 100644 lispusers/MIGRATION/MIGRATION-TOOL create mode 100644 lispusers/MIGRATION/MIGRATION-TOOL.LCOM create mode 100644 lispusers/MIGRATION/SEDIT-DECLS create mode 100644 lispusers/MIGRATION/SEDIT-DECLS.LCOM create mode 100644 lispusers/MIGRATION/TABLEBROWSERDECLS create mode 100644 lispusers/MIGRATION/TABLEBROWSERDECLS.LCOM create mode 100644 lispusers/MIGRATION/TRANSLATOR-ASSISTANT diff --git a/lispusers/MIGRATION/DIR.TXT b/lispusers/MIGRATION/DIR.TXT new file mode 100644 index 00000000..4671a652 --- /dev/null +++ b/lispusers/MIGRATION/DIR.TXT @@ -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. diff --git a/lispusers/MIGRATION/FILEPKGRECORDS b/lispusers/MIGRATION/FILEPKGRECORDS new file mode 100644 index 00000000..e424bee0 --- /dev/null +++ b/lispusers/MIGRATION/FILEPKGRECORDS @@ -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 diff --git a/lispusers/MIGRATION/FILEPKGRECORDS.LCOM b/lispusers/MIGRATION/FILEPKGRECORDS.LCOM new file mode 100644 index 00000000..1d535001 --- /dev/null +++ b/lispusers/MIGRATION/FILEPKGRECORDS.LCOM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED "19-Jan-93 19:53:16" ("compiled on " {DSK}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 \ No newline at end of file diff --git a/lispusers/MIGRATION/IL-CONVERT b/lispusers/MIGRATION/IL-CONVERT new file mode 100644 index 00000000..dfba32c5 --- /dev/null +++ b/lispusers/MIGRATION/IL-CONVERT @@ -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 diff --git a/lispusers/MIGRATION/IL-CONVERT.LCOM b/lispusers/MIGRATION/IL-CONVERT.LCOM new file mode 100644 index 00000000..6dc9c25a --- /dev/null +++ b/lispusers/MIGRATION/IL-CONVERT.LCOM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "IL-CONVERT" BASE 10) (IL:FILECREATED "19-Jan-93 19:53:39" ("compiled on " IL:|{DSK}local>src>tape>MIGRATION>IL-CONVERT.;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: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|) (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))) (IL:BQUOTE (DEFUN ( IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-IF-NEEDED"))) (ARGS) (CASE (LENGTH ARGS) (0 (IL:\\\, (EVAL (IL:BQUOTE ((IL:\\\, NAME)))))) (1 (FIRST ARGS)) (T (IL:BQUOTE ((IL:\\\, (QUOTE (IL:\\\, NAME))) (IL:\\\,@ 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 (QUOTE CONVERT-FILE)) ) (IL:* IL:|;;| "(convert-file \"~/medley/ADISPLAY\" \"adisplay\") (convert-file \"foo1\" \"foo2\") (convert-file \"foo3\" \"foo4\")" ) (IL:P (EXPORT (QUOTE (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 (IL:BQUOTE (SETF (GET (QUOTE ( IL:\\\, FN-NAME)) (QUOTE CONVERT-FORM)) (FUNCTION (LAMBDA (IL:\\\, ARGLIST) (IL:\\\,@ REST))))) (PROGN (WARN "No symbol ~:@(~a~) found in IL package." NAME) NIL)))) (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)) (IL:BQUOTE (SETF ( GET (QUOTE (IL:\\\, SYM)) (QUOTE CONVERT-FORM)) (FUNCTION (LAMBDA (&REST ARGS) (CONS (QUOTE (IL:\\\, NAME)) (MAPCONVERT ARGS)))))))) (XCL:DEFDEFINER IL-DEFUN IL:FUNCTIONS (NAME &REST REST) (CHECK-TYPE NAME SYMBOL) (LET* ((NAME-STRING ( SYMBOL-NAME NAME)) (IL-SYM (INTERN NAME-STRING (QUOTE IL))) (IL-SYM1 (IF (CHAR/= (ELT NAME-STRING 0) #\/) (INTERN (CONCATENATE (QUOTE STRING) "/" NAME-STRING) (QUOTE IL))))) (IL:BQUOTE (PROGN (EXPORT ( QUOTE (IL:\\\, IL-SYM)) (QUOTE IL)) (DEFUN (IL:\\\, IL-SYM) (IL:\\\,@ REST)) (IL:* IL:\; "Also make a version starting with a /") (IL:\\\,@ (IF IL-SYM1 (IL:BQUOTE ((EXPORT (QUOTE (IL:\\\, IL-SYM1)) (QUOTE IL)) (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, IL-SYM1))) (SYMBOL-FUNCTION (QUOTE (IL:\\\, IL-SYM)))))))))))) (XCL:DEFDEFINER IL-DEFVAR IL:FUNCTIONS (NAME &REST ARGS) (LET ((IL-SYM (INTERN (SYMBOL-NAME NAME) *IL-PACKAGE*))) (IL:BQUOTE (PROGN (EXPORT (QUOTE (IL:\\\, IL-SYM)) (QUOTE IL)) (DEFVAR (IL:\\\, IL-SYM ) (IL:\\\,@ (MAPCONVERT ARGS))))))) (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)) (IL:BQUOTE (SETF (GET (QUOTE (IL:\\\, NEW-SYM)) ( QUOTE CONVERT-FORM)) (FUNCTION (LAMBDA (&REST ARGS) (APPLY (GET (QUOTE (IL:\\\, OLD-SYM)) (QUOTE CONVERT-FORM)) ARGS))))))) (XCL:DEFDEFINER IL-WARNINGFORM IL:FUNCTIONS (NAME &OPTIONAL (TEMPLATE (QUOTE (NIL REPEAT (EVAL)))) ( WARN-SWITCH (QUOTE *WARN-ON-UNTRANSLATABLE-IL-FORM*))) (LET ((FN-NAME (FIND-SYMBOL (SYMBOL-NAME NAME) *IL-PACKAGE*))) (IF FN-NAME (IL:BQUOTE (SETF (GET (QUOTE (IL:\\\, FN-NAME)) (QUOTE CONVERT-FORM)) ( FUNCTION (LAMBDA (&REST REST) (DECLARE (SPECIAL (IL:\\\, WARN-SWITCH))) (WHEN (IL:\\\, WARN-SWITCH) ( WARN "Unable to translate a ~a form." (QUOTE (IL:\\\, FN-NAME)))) (WALK-TEMPLATE (CONS (QUOTE (IL:\\\, FN-NAME)) REST) (QUOTE (IL:\\\, TEMPLATE))))))) (PROGN (WARN "No symbol ~:@(~a~) found in IL package." NAME) NIL)))) (MACROLET ((DEF-*-IF-NEEDED (NAME) (LET ((NAME-STRING (SYMBOL-NAME NAME))) (IL:BQUOTE (DEFUN (IL:\\\, (INTERN (CONCATENATE (QUOTE STRING) NAME-STRING "-IF-NEEDED"))) (ARGS) (CASE (LENGTH ARGS) (0 (IL:\\\, (EVAL (IL:BQUOTE ((IL:\\\, NAME)))))) (1 (FIRST ARGS)) (T (IL:BQUOTE ((IL:\\\, (QUOTE (IL:\\\, NAME)) ) (IL:\\\,@ 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) (DEFUN QUOTED-SYMBOL-P (X) (AND (CONSP X) (EQ (CAR X) (QUOTE 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 (QUOTE 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 (QUOTE CONVERT-FILE)) (EXPORT (QUOTE (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)))))) (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* (FUNCTION STRING<) :KEY (FUNCTION 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 (QUOTE STOP)) ) (QUOTE 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 (FUNCTION (LAMBDA (KEY VALUE) (SETF (SVREF SORTED-TABLE I) (CONS KEY VALUE)) ( INCF I))) HT) (SORT SORTED-TABLE (FUNCTION STRING<) :KEY (FUNCTION (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 (QUOTE IL)))) (COMS (SYMBOL-VALUE (OR (CAAR (GET REAL-FILENAME (QUOTE IL:FILE))) (ERROR "~a has no FILES definition." FILENAME))))) (IF OUTFILE (WITH-OPEN-STREAM (OUTSTREAM (COND ((EQ OUTFILE (QUOTE 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 (QUOTE CONVERT-ONE-FILECOM) REORDERED-FILECOMS))) (WHEN OUTSTREAM (FORMAT T "~&Writing output...") (LET* (( MFE (GET FILENAME (QUOTE IL:MAKEFILE-ENVIRONMENT))) (*PACKAGE* (OR (FIND-PACKAGE (EVAL (GETF MFE :PACKAGE))) *IL-PACKAGE*)) (*PRINT-PRETTY* T) (*PRINT-CASE* :DOWNCASE)) (WHEN MFE (PRINT (QUOTE ( IN-PACKAGE "INTERLISP" :USE NIL :NICKNAMES (QUOTE ("IL")))) OUTSTREAM)) (PRINT (IF MFE (LIST (QUOTE IN-PACKAGE) (GETF MFE (QUOTE :PACKAGE))) (QUOTE (IN-PACKAGE "INTERLISP" :USE NIL :NICKNAMES (QUOTE ( "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) (QUOTE CONVERT-COM))) (IL:* IL:|;;| "FILEVARS are handled at this level, except in PROP and IFPROP coms.") (FILEVAR-P (AND (EQ (SECOND COM ) (QUOTE IL:*)) (NOT (MEMBER (FIRST COM) (QUOTE (IL:* IL:PROP IL:IFPROP))))))) (FUNCALL (OR CONVERTER (QUOTE 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) (QUOTE 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) (QUOTE (IL:CONSTANTS IL:MACROS))) (AND (MEMBER (CAR COM) (QUOTE (IL:DECLARE\: ))) (SOME (FUNCTION 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 (QUOTE PROGN) (MAPCAR (FUNCTION (LAMBDA (P) (IL:BQUOTE (EXPORT (MAPCAR (QUOTE INTERN) (QUOTE ( IL:\\\, (MAPCAR (QUOTE STRING) (CDR P)))) (QUOTE (IL:\\\, (PACKAGE-NAME (CAR P))))))))) SORTED)))) (DEFPARAMETER *WALKER-TEMPLATES* (QUOTE (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 (QUOTE (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 (QUOTE CONVERT-FORM)) ( EQ (CAR (GET FN (QUOTE IL:CLISPWORD))) (QUOTE 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 ( QUOTE (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 (QUOTE 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 (QUOTE :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) (QUOTE 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 (QUOTE BINDING)) (WALK-TEMPLATE FORM (QUOTE (BINDING EVAL REPEAT (BINDING)))))) ((PARAMETER-LIST) (WHEN *WALKER-FIND-PARAMETER-LIST* (IL:* IL:|;;| "Some code-analysis stuff uses this.") (THROW (QUOTE PARAMETER-LIST) FORM)) (WALK-TEMPLATE FORM (QUOTE (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 (QUOTE 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:PUTPROPS IL:IL-CONVERT IL:COPYRIGHT ("ENVOS Corporation" 1989 1990)) NIL \ No newline at end of file diff --git a/lispusers/MIGRATION/IL-LOOPS b/lispusers/MIGRATION/IL-LOOPS new file mode 100644 index 00000000..c80fc9d9 --- /dev/null +++ b/lispusers/MIGRATION/IL-LOOPS @@ -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 diff --git a/lispusers/MIGRATION/IL-LOOPS.LCOM b/lispusers/MIGRATION/IL-LOOPS.LCOM new file mode 100644 index 00000000..02ffb7df --- /dev/null +++ b/lispusers/MIGRATION/IL-LOOPS.LCOM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "19-Jan-93 19:54:08" ("compiled on " {DSK}local>src>tape>MIGRATION>IL-LOOPS.;1) "11-Jul-91 21:52:09" bcompl'd in "Lispcore 11-Jul-91 ..." dated "11-Jul-91 21:57:45") (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) (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 (QUOTE 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) ( BQUOTE ((\, 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) (BQUOTE ((\, (IL-CONVERT::MAKE-FAKE-SYMBOL "FIND-CLASS")) (QUOTE (\, (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) ( BQUOTE (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)) (BQUOTE (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) (QUOTE GetWrappedValue) NIL (QUOTE METHOD))) (IL-CONVERT::GMCLASS (CL:SECOND (GETDEF IL-CONVERT::GM (QUOTE METHODS)))) (IL-CONVERT::PM (GetIt (Class IL-CONVERT::OBJ) (QUOTE PutWrappedValue) NIL (QUOTE METHOD)) ) (IL-CONVERT::PMCLASS (CL:SECOND (GETDEF IL-CONVERT::PM (QUOTE 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 (BQUOTE (_ (\, IL-CONVERT::SELFVAR) (\, IL-CONVERT::LOCALSTATE))))) (CL:DEFUN IL-CONVERT::CONVERT-CLASSES (IL-CONVERT::CS) (IL-CONVERT::MAP-INTO-CONTEXT (QUOTE IL-CONVERT::CONVERT-ONE-CLASS) IL-CONVERT::CS)) (CL:DEFUN IL-CONVERT::CONVERT-METHODS (IL-CONVERT::MS) (CONS (QUOTE PROGN) (IL-CONVERT::MAP-INTO-CONTEXT (QUOTE 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 (QUOTE *) (QUOTE ;;) (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 (QUOTE MetaClass) IL-CONVERT::ATTRIBUTES))) (IL-CONVERT::SUPERS (CDR (CL:ASSOC (QUOTE Supers ) IL-CONVERT::ATTRIBUTES))) (IL-CONVERT::CVS (CDR (CL:ASSOC (QUOTE ClassVariables) IL-CONVERT::ATTRIBUTES ))) (IL-CONVERT::IVS (CDR (CL:ASSOC (QUOTE 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 ) (BQUOTE (IL-CONVERT::FIND-CLASS (QUOTE (\, (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 (CL:FUNCTION 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) (QUOTE doc))) (IL-CONVERT::CONVERSION (CL:IF (type? annotatedValue IL-CONVERT::OBJ) (IL-CONVERT::AV-CONVERT IL-CONVERT::NAME IL-CONVERT::DOC IL-CONVERT::OBJ) (BQUOTE ((\, IL-CONVERT::NAME) (\,@ (AND (CDR IL-CONVERT::SPEC ) (BQUOTE (:INITFORM (\, (IL-CONVERT::LOOPS-CONVERT IL-CONVERT::OBJ)))))) :INITARG (\, (CL:INTERN ( STRING (CL:FIRST IL-CONVERT::SPEC)) *KEYWORD-PACKAGE*)) (\,@ (AND IL-CONVERT::ALLOC (BQUOTE ( :ALLOCATION (\, IL-CONVERT::ALLOC))))) (\,@ (AND IL-CONVERT::DOC (BQUOTE (: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:") (QUOTE (CL:REMF IL-CONVERT::PROPS (QUOTE 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 (BQUOTE ((\, ( IL-CONVERT::MAKE-FAKE-SYMBOL "DEFCLASS")) (\, IL-CONVERT::CLASSNAME) (\, (IL-CONVERT::MAPCONVERT IL-CONVERT::SUPERS)) ((\,@ (CL:REMOVE-IF (QUOTE NULL) (CL:MAPCAR (CL:FUNCTION IL-CONVERT::PROCESS-IV) IL-CONVERT::IVS))) (\,@ (CL:REMOVE-IF (QUOTE 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*) (BQUOTE (IL-CONVERT::.PROPS-ALIST. :INITFORM (QUOTE (\, IL-CONVERT::PROPS-ALIST))))))) (\,@ (CL:UNLESS (EQ (CAR IL-CONVERT::META) (QUOTE Class)) (LET (( IL-CONVERT::*CURRENT-EXPRESSION* (IL-CONVERT:CONVERT (CAR IL-CONVERT::META)))) (CL:WARN "Metaclass might be incorrect") (BQUOTE (:METACLASS (\, IL-CONVERT::*CURRENT-EXPRESSION*)))))))))) ( CL:IF IL-CONVERT::AUX-DEFS (BQUOTE (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 (QUOTE 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 (QUOTE &OPTIONAL) (CDR IL-CONVERT::NEW-VARLST)))) (BQUOTE ((\, (IL-CONVERT::MAKE-FAKE-SYMBOL (QUOTE 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* (QUOTE (&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) (BQUOTE ((\, (IL-CONVERT::MAKE-FAKE-SYMBOL ( QUOTE 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)) ( BQUOTE (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 (QUOTE 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 (QUOTE 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 (QUOTE self) IL-CONVERT::LS) ) (IL-CONVERT::ACCESSOR (IL-CONVERT::MAKE-FAKE-SYMBOL (CL:CONCATENATE (QUOTE STRING) "!ACCESSOR-FOR-" CL:NAMESTRING)))) (CL:PUSH (BQUOTE ((\, (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 (QUOTE (ReplaceMe NoUpdatePermitted))) (LET ((IL-CONVERT::CODEWRITER (GET IL-CONVERT::PF (QUOTE 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 (QUOTE self) IL-CONVERT::LS))) (CL:PUSH ( BQUOTE ((\, (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 (QUOTE CL:VALUES) (* ; "values-list* y'might say") (AND IL-CONVERT::VARNAME (BQUOTE ((\, IL-CONVERT::VARNAME) (\,@ (AND (EQ IL-CONVERT::PF (QUOTE ReplaceMe)) (BQUOTE (: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) (BQUOTE (CL:IF (IL-CONVERT::SLOT-BOUNDP (\, IL-CONVERT::SELFVAR) (QUOTE (\, IL-CONVERT::VARNAME))) (IL-CONVERT::SLOT-VALUE (\, IL-CONVERT::SELFVAR) (QUOTE (\, IL-CONVERT::VARNAME ))) (CL:SETF (IL-CONVERT::SLOT-VALUE (\, IL-CONVERT::SELFVAR) (QUOTE (\, IL-CONVERT::VARNAME))) ( IL-CONVERT::SLOT-VALUE (\, IL-CONVERT::SELFVAR) (QUOTE (\, IL-CONVERT::LOCALSTATE))))))) (CL:DEFUN IL-CONVERT::FFSENDSELF-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR IL-CONVERT::LOCALSTATE ) (BQUOTE (CL:IF (IL-CONVERT::SLOT-BOUNDP (\, IL-CONVERT::SELFVAR) (QUOTE (\, IL-CONVERT::VARNAME))) ( IL-CONVERT::SLOT-VALUE (\, IL-CONVERT::SELFVAR) (QUOTE (\, IL-CONVERT::VARNAME))) (CL:SETF ( IL-CONVERT::SLOT-VALUE (\, IL-CONVERT::SELFVAR) (QUOTE (\, IL-CONVERT::VARNAME))) (\, (IL-CONVERT:CONVERT (BQUOTE (_ (\, IL-CONVERT::SELFVAR) (\, IL-CONVERT::LOCALSTATE))))))))) (CL:DEFUN IL-CONVERT::FIRSTFETCH-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR IL-CONVERT::LOCALSTATE ) (BQUOTE (CL:IF (IL-CONVERT::SLOT-BOUNDP (\, IL-CONVERT::SELFVAR) (QUOTE (\, IL-CONVERT::VARNAME))) ( IL-CONVERT::SLOT-VALUE (\, IL-CONVERT::SELFVAR) (QUOTE (\, IL-CONVERT::VARNAME))) (CL:SETF ( IL-CONVERT::SLOT-VALUE (\, IL-CONVERT::SELFVAR) (QUOTE (\, IL-CONVERT::VARNAME))) (\, (CL:IF (OR ( CL:SYMBOLP IL-CONVERT::LOCALSTATE) (IL-CONVERT::FAKE-SYMBOL-P IL-CONVERT::LOCALSTATE)) (BQUOTE ( CL:FUNCALL (\, IL-CONVERT::LOCALSTATE))) IL-CONVERT::LOCALSTATE)))))) (CL:DEFUN IL-CONVERT::GETFROMIV-ACCESSOR-WRITER (IL-CONVERT::VARNAME IL-CONVERT::SELFVAR IL-CONVERT::LOCALSTATE ) (BQUOTE (IL-CONVERT::SLOT-VALUE (\, IL-CONVERT::SELFVAR) (QUOTE (\, 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 QUOTE))) (LIST (IL-CONVERT::MAKE-FAKE-SYMBOL (CL:CONCATENATE (QUOTE 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 (BQUOTE (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)) NIL \ No newline at end of file diff --git a/lispusers/MIGRATION/IL-RECORD b/lispusers/MIGRATION/IL-RECORD new file mode 100644 index 00000000..7982eb2b --- /dev/null +++ b/lispusers/MIGRATION/IL-RECORD @@ -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 diff --git a/lispusers/MIGRATION/IL-RECORD.LCOM b/lispusers/MIGRATION/IL-RECORD.LCOM new file mode 100644 index 00000000..7f61df57 --- /dev/null +++ b/lispusers/MIGRATION/IL-RECORD.LCOM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE "IL-CONVERT" READTABLE "XCL") (IL:FILECREATED "19-Jan-93 19:54:35" ("compiled on " IL:|{DSK}local>src>tape>MIGRATION>IL-RECORD.;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 "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|) (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))) (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)))))))) (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))))))) (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-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-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)) NIL \ No newline at end of file diff --git a/lispusers/MIGRATION/IL-SIM b/lispusers/MIGRATION/IL-SIM new file mode 100644 index 00000000..db54a3f6 --- /dev/null +++ b/lispusers/MIGRATION/IL-SIM @@ -0,0 +1,1356 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (CLIN-PACKAGE "IL-CONVERT") +*PACKAGE*) BASE 10) +(IL:FILECREATED "25-Jan-90 11:04:43" IL:|{DSK}/users/welch/migration/IL-SIM.;3| 88504 + + IL:|changes| IL:|to:| (IL:FUNCTIONS NTHCHARCODE ERROR) + + IL:|previous| IL:|date:| "25-Jan-90 08:58:55" IL:|{DSK}/users/welch/migration/IL-SIM.;2|) + + +; Copyright (c) 1989, 1990 by ENVOS Corporation. All rights reserved. + +(IL:PRETTYCOMPRINT IL:IL-SIMCOMS) + +(IL:RPAQQ IL:IL-SIMCOMS ((IL:* IL:|;;| "Converter macros Have to add \"CL\" as a nickname to the LISP package since some Interlisp code names it that way.") (IL:P (IN-PACKAGE (QUOTE IL-CONVERT))) (IL:FUNCTIONS CONVERT-TO-STRING SIMP-MINUS SIMP-1- QUOTE-TREE EXPAND-VARLIST) (IL:FUNCTIONS RPAQQ RPAQ RPAQ?) (IL:FUNCTIONS CONSTANTS) (IL:* IL:\| "chapter 2") (IL:VARIABLES *WARN-FOR-ALL-IL-SYMBOLS* *WARN-FOR-IL-SYMBOLS-LOWER-THAN-THIS* *WARN-ON-CHAR-CODE-USE*) (IL:P (IL-COPYDEF ATOM) (IL-COPYDEF BOUNDP) (IL-COPYDEF SET)) (IL:FUNCTIONS LITATOM SETQQ SETQ PSETQ) (IL:FUNCTIONS (IL:* IL:\; "warning forms") IL:GETTOPVAL IL:SETTOPVAL) (IL:* IL:|;;| "with Franz, might want to use mp:global-symbol-value for the following") (IL:P (IL-COPYDEF SET SETATOMVAL)) (IL:FUNCTIONS GETATOMVAL GETPROP PUTPROP ADDPROP) (IL:FUNCTIONS REMPROP REMPROPLIST CHANGEPROP) (IL:FUNCTIONS (IL:* IL:\; "warning forms") IL:PROPNAMES IL:DEFLIST) (IL:P (IL-COPYDEF SYMBOL-PLIST GETPROPLIST) (IL-COPYDEF GENTEMP GENSYM)) (IL:FUNCTIONS MKATOM L-CASE U-CASE) (IL:FUNCTIONS SETPROPLIST CHARCODE NTHCHARCODE CHARACTER CHCON1 EVAL-IF-POSSIBLE SELCHARQ) (IL:P (IL-COPYCONV CHARACTER FCHARACTER)) (IL:FUNCTIONS (IL:* IL:\; "warning forms") IL:PACK IL:PACK* IL:UNPACK IL:DUNPACK IL:MAPATOMS IL:APROPOS) (IL:* IL:\; "***** rest of chapter 2") (IL:* IL:\| "Chapter 3") (IL:FUNCTIONS NLISTP) (IL:* IL:\; "***** CAR/CDRERR") (IL:P (IL-COPYDEF CONS) (IL-COPYDEF LISTP) (IL-COPYDEF CAR) (IL-COPYDEF CDR) (IL-COPYDEF CADR) (IL-COPYDEF CDAR) (IL-COPYDEF CDDR) (IL-COPYDEF CAAAR) (IL-COPYDEF CAADR) (IL-COPYDEF CADAR) (IL-COPYDEF CADDR) (IL-COPYDEF CDAAR) (IL-COPYDEF CDADR) (IL-COPYDEF CDDAR) (IL-COPYDEF CDDDR) (IL-COPYDEF CAAAAR) (IL-COPYDEF CAAADR) (IL-COPYDEF CAADAR) (IL-COPYDEF CAADDR) (IL-COPYDEF CADAAR) (IL-COPYDEF CDDDAR) (IL-COPYDEF CDDDDR) (IL-COPYDEF RPLACD) (IL-COPYDEF RPLACD FRPLACD) (IL-COPYDEF RPLACA) (IL-COPYDEF RPLACA FRPLACA)) (IL:FUNCTIONS RPLNODE RPLNODE2 FRPLNODE FRPLNODE2 MKLIST NCONC1) (IL:P (IL-COPYDEF LIST) (IL-COPYDEF LIST*) (IL-COPYDEF APPEND) (IL-COPYDEF NCONC) (IL-COPYDEF TAILP) (IL-COPYDEF LAST) (IL-COPYDEF LENGTH) (IL-COPYDEF LENGTH FLENGTH) (IL-COPYDEF SET-DIFFERENCE LDIFFERENCE) (IL-COPYDEF INTERSECTION) (IL-COPYDEF UNION)) (IL:FUNCTIONS ATTACH LCONC TCONC) (IL:FUNCTIONS IL:DOCOLLECT IL:ENDCOLLECT IL:SCRATCHLIST IL:ADDTOSCRATCHLIST IL:COPYALL IL:HCOPYALL IL:NLEFT IL:LASTN IL:COUNT IL:COUNTDOWN IL:EQUALN IL:LDIFF IL:LSUBST IL:SUBPAIR) (IL:* IL:\; "warning forms ") (IL:P (IL-COPYDEF COPY-LIST COPY)) (IL:FUNCTIONS NTH MEMB FMEMB MEMBER EQMEMB SUBST DSUBST SUBLIS DSUBLIS ASSOC SASSOC PUTASSOC) (IL:P (IL-COPYCONV NTH FNTH) (IL-COPYCONV LAST FLAST) (IL-COPYCONV MEMB FMEMB) (IL-COPYCONV ASSOC FASSOC) (IL-COPYDEF GETF LISTGET)) (IL:FUNCTIONS LISTPUT LISTGET1 MERGE) (IL:FUNCTIONS IL:LISTPUT1 IL:ALPHORDER IL:UALPHORDER IL:COMPARELISTS) (IL:* IL:\; "warning forms") (IL:FUNCTIONS REMOVE DREMOVE REVERSE DREVERSE) (IL:FUNCTIONS NEGATE) (IL:* IL:\| "chapter 4") (IL:P (IL-COPYDEF STRINGP)) (IL:FUNCTIONS STREQUAL STRING-EQUAL NCHARS ALLOCSTRING MKSTRING CONCAT CONCATLIST RPLSTRING RPLCHARCODE STRPOS SUBSTRING) (IL:* IL:|;;| " Warning Forms") (IL:FUNCTIONS IL:GNC IL:GLC) (IL:* IL:\| "chapter 5") (IL:* IL:\; "***** chapter 5 (arrays)") (IL:* IL:\| "chapter 6") (IL:FUNCTIONS MAPHASH GETHASH PUTHASH) (IL:* IL:\; "***** chapter 6 (hash arrays)") (IL:* IL:\| "chapter 7") (IL:FUNCTIONS SMALLP) (IL:* IL:\; "*** ??") (IL:FUNCTIONS FIXP) (IL:P (IL-COPYDEF FLOATP) (IL-COPYDEF NUMBERP) (IL-COPYDEF EQUALP EQP)) (IL:* IL:|;;| "(il-defconv EQP (x y) `(eql ,^x ,^y)) ***** overflow") (IL:FUNCTIONS PLUS MINUS DIFFERENCE TIMES) (IL:* IL:\; "***** remainder ") (IL:FUNCTIONS GREATERP LESSP GEQ LEQ) (IL:P (IL-COPYDEF ZEROP) (IL-COPYDEF MINUSP) (IL-COPYDEF MIN) (IL-COPYDEF MAX) (IL-COPYDEF ABS)) (IL:* IL:\; "***** min.integer,^ max.integer") (IL:FUNCTIONS IPLUS IMINUS IDIFFERENCE ADD1 SUB1 ITIMES IQUOTIENT IREMAINDER IMOD IGREATERP ILESSP IGEQ ILEQ IMIN IMAX IEQP FIX FIXR RSH POWEROFTWOP EVENP ODDP BITTEST BITCLEAR) (IL:P (IL-COPYDEF GCD) (IL-COPYDEF LOGAND) (IL-COPYDEF LOGIOR LOGOR) (IL-COPYDEF ASH LSH) (IL-COPYDEF INTEGER-LENGTH INTEGERLENGTH) (IL-COPYDEF LOGNOT) (IL-COPYDEF LOGIOR BITSET)) (IL:FUNCTIONS MASK.1\'S MASK.0\'S LOADBYTE DEPOSITBYTE) (IL:P (IL-COPYDEF BYTE) (IL-COPYDEF BYTE-SIZE BYTESIZE) (IL-COPYDEF BYTE-POSITION BYTEPOSITION) (IL-COPYDEF LDB) (IL-COPYDEF DPB)) (IL:FUNCTIONS (IL:* IL:\; "warning forms") IL:ROT) (IL:* IL:|;;| " *** section 7.4 (floating point)") (IL:* IL:\| "chapter 8") (IL:* IL:|;;| " **** Record stuff in IL-RECORD.lisp *** Changetran...") (IL:FUNCTIONS |push| |add| |change| |pushnew| |pushlist| |swap|) (IL:P (IL-COPYCONV |push| PUSH) (IL-COPYCONV |add| ADD) (IL-COPYCONV |change| CHANGE) (IL-COPYCONV |pushnew| PUSHNEW) (IL-COPYCONV |pushlist| PUSHLIST) (IL-COPYCONV |swap| SWAP) (IL-COPYDEF POP) (IL-COPYDEF POP |pop|)) (IL:* IL:\| "chapter 9") (IL:* IL:\; "**** 9.1") (IL:P (IL-COPYDEF EQ) (IL-COPYDEF NULL) (IL-COPYDEF NOT) (IL-COPYDEF EQUAL) (IL-COPYDEF AND) (IL-COPYDEF OR)) (IL:FUNCTIONS NEQ) (IL:* IL:\; "EQP is in chapter 7") (IL:* IL:\; "***** EQUALALL") (IL:FUNCTIONS COND) (IL:* IL:|;;| " (convert '(il:cond ((il:geq 3 2) (il:times 2 3))))") (IL:FUNCTIONS |if|) (IL:P (IL-COPYCONV |if| IF)) (IL:* IL:|;;| " +(convert '(il:|if| (il:geq a b) il:|then| (foo) + il:|elseif| (il:atom (il:plus 2 3)) il:|then| (bar) + il:|else| (baz))) +") (IL:FUNCTIONS SELECTQ SELECTC CASE) (IL:* IL:|;;| " +(convert '(il:selectq (il:plus 2 3) (a (il:times a b)) (il:plus c d))) +") (IL:* IL:\; "***** SELECTC") (IL:P (IL-COPYDEF PROG1) (IL-COPYDEF PROG2) (IL-COPYDEF PROGN) (IL-COPYDEF RETURN) (IL-COPYDEF RETURN-FROM RETFROM)) (IL:* IL:|;;| "If we were really clever we could keep track of when we were inside a PROG. Then we could treat (top-level) symbols as prog labels and not put them in the IL package. In that case we would want GO to generate `(go ,tag) instead of `(go ,^tag).") (IL:FUNCTIONS GO PROG LET LET* PROG* CONVERT-DO CONVERT-DO*) (IL:P (IL:* IL:|;;| "One case where il-defconv won't do what we need...") (SETF (GET (QUOTE DO) (QUOTE CONVERT-FORM)) (QUOTE CONVERT-DO) (GET (QUOTE DO*) (QUOTE CONVERT-FORM)) (QUOTE CONVERT-DO*))) (IL:* IL:|;;| "I.S. stuff - entry is coded into CONVERT") (IL:VARIABLES *ITERATION-CONVERSION-TABLE*) (IL:FUNCTIONS CONVERT-ITERATION-STATEMENT FILTER-NUMERIC-BY FILTER-LIST-BY FILTER-BIND FILTER-DO FILTER-INSTRING FILTER-REPEATWHILE/UNTIL) (IL:* IL:\| "chapter 10") (IL:* IL:|;;| "These variables can be set to T to make lambdas come out with &REST IGNORE (equiv.) and &OPTIONAL in their parm. lists.") (IL:VARIABLES *ADD-REST-ARG* *PARAMETERS-ALWAYS-OPTIONAL*) (IL:FUNCTIONS DEFINEQ1 ARG SETARG DEFINEQ) (IL:* IL:|;;| "(convert '(defineq (foo (lambda (a b) (plus a b c))))) (convert '(defineq (foo (nlambda (a b) (plus a b c))))) (convert '(defineq (foo (lambda x (plus (arg x 1) (arg x 2)))))) (convert '(defineq (foo (nlambda x (mapcar 'foo x))))) ***** FNTYP, EXPRP, CCODEP, ARGTYPE, NARGS, ARGLIST, SMARTARGLIST ***** DEFINE ***** UNSAVE.TO.MODIFY.FNS, DFNFLG") (IL:FUNCTIONS PUTD CCODEP) NIL (IL:P (IL-COPYDEF SYMBOL-FUNCTION GETD) (IL-COPYDEF APPLY) (IL-COPYDEF FUNCALL APPLY*)) (IL:FUNCTIONS KWOTE) (IL:* IL:|;;| "(il-defconv QUOTE (&rest args) `(quote ,@args)) ***** NLAMBDA.ARGS,^ EVALA,^ DEFEVAL,^ EVALHOOK") (IL:* IL:|;;| " +; is this right? +(il-defconv RPTQ (n &rest forms) + `(do ((IL::RPTN ,^(eval n) (1- IL::RPTN)) + val) + ((<= IL::RPTN 0) val) + (declare (special IL::RPTN)) + (setq val (progn ,@^@forms)))) +") (IL:* IL:\; "***** RPTQ, FRPTQ") (IL:FUNCTIONS MOVD MAP MAPC MAPLIST MAPCAR MAPCON MAPCONC MAP2C MAP2CAR SUBSET) (IL:* IL:\; "***** rest of chapter") (IL:FUNCTIONS IL:MOVD?) (IL:* IL:\| "chapter 14") (IL:VARIABLES *WARN-ON-ERSETQ-NLSETQ*) (IL:FUNCTIONS SHOULDNT ERROR NLSETQ ERSETQ) (IL:* IL:\| "chapter 17") (IL:VARIABLES *EVAL-WHEN-STATE*) (IL:FUNCTIONS DECLARE\:) (IL:FUNCTIONS PUTPROPS DEFINE-MACRO DEFINE-SUBST-MACRO QUOTE) (IL:* IL:|;;| "(il-defconv * (&rest args) `(il::* ,@args))") (IL:* IL:|;;| "what are we supposed to do with (declare (specvars . t)) ?") (IL:VARIABLES *TYPE-CONVERSION-PLIST*) (IL:FUNCTIONS DECLARE FILEMAP ADDTOVAR APPENDTOVAR FUNCTION LAMBDA DEFINE-FILE-INFO PRETTYCOMPRINT) (IL:P (SETF (GET (QUOTE FILECREATED) (QUOTE EARLY)) T)) (IL:FUNCTIONS FILECREATED) (IL:* IL:\| "chapter 18") (IL:FUNCTIONS CONSTANT) (IL:* IL:\| "chapter 23") (IL:P (IL-COPYDEF PROCESSP)) (IL:FUNCTIONS CREATE.MONITORLOCK OBTAIN.MONITORLOCK RELEASE.MONITORLOCK WITH.MONITOR NOTIFY.EVENT THIS.PROCESS) (IL:FUNCTIONS (IL:* IL:\; "warningforms...") IL:AWAIT.EVENT IL:CREATE.EVENT) (IL:* IL:\| "chapter 24") (IL:FUNCTIONS OPENSTRINGSTREAM) (IL:* IL:\| "chapter 25") (IL:P (IL-COPYDEF PRINT) (IL-COPYDEF TERPRI) (IL-COPYDEF PRIN1 PRIN2) (IL-COPYDEF PRINC PRIN1) (IL-COPYDEF READ-CHAR BIN) (IL-COPYDEF WRITE-CHAR BOUT)) (IL:VARIABLES *ANNOTATE-PRINTOUT-FORM*) (IL:FUNCTIONS PRINTOUT READ READP) (IL:P (IL-COPYCONV PRINTOUT |printout|)) (IL:* IL:|;;| "Warning forms") (IL:FUNCTIONS IL:INPUT IL:RATOM IL:RSTRING IL:RATOMS IL:RATEST IL:READC IL:PEEKC IL:LASTC IL:READCCODE IL:PEEKCCODE IL:READP IL:EOFP IL:WAITFORINPUT IL:SKREAD IL:SKIPSEPRS IL:OUTPUT IL:PRIN3 IL:PRIN4 IL:PRINTCCODE IL:TAB IL:SHOWPRIN2 IL:SHOWPRINT IL:PRINTBELLS IL:LINELENGTH IL:SETLINELENGTH) (IL:* IL:\| "Unconvertable things...") (IL:* IL:|;;| "Warning forms") (IL:FUNCTIONS IL:WINDOWADDPROP IL:\\PUTBASE IL:\\GETBASE IL:DSPLEFTMARGIN IL:RESETLST IL:WINDOWPROP) (IL:FUNCTIONS IL:SMARTARGLIST IL:EDITGETD IL:FIND.PROCESS IL:PROCESS.EVALV IL:PROCESSP IL:PROCESS.EVAL IL:FREEMENU IL:FM.RESETMENU IL:FM.CHANGESTATE IL:FM.CHANGELABEL IL:FM.ITEMPROP IL:FM.EDITITEM IL:FM.GETITEM IL:MAINWINDOW IL:RESETFORM IL:SETTERMTABLE IL:PROCESSPROP IL:TTY.PROCESS IL:CLEARW IL:\\CARET.DOWN IL:\\SMASHSTRING IL:BKSYSBUF IL:CLEARBUF IL:GETSYNTAX IL:OPENWP IL:STRINGWIDTH IL:CHARWIDTH IL:FLASHWINDOW IL:MENU IL:FONTCREATE IL:TTYINPROMPTFORWORD IL:MOUSECONFIRM IL:CLOSEW IL:ATTACHWINDOW IL:SHAPEW IL:CONCATLIST IL:GETPROMPTWINDOW IL:BITBLT IL:BLTSHADE IL:BITMAPWIDTH IL:BITMAPHEIGHT IL:FONTPROP IL:TEDIT.INSERT IL:TEDIT.PARALOOKS IL:DSPCLIPPINGREGION IL:MOVETO IL:RELMOVETO IL:DSPFONT IL:DSPXPOSITION IL:CURSORCREATE IL:WAIT.FOR.TTY IL:\\SAVEVMEMBACKGROUND IL:GETREGION IL:WINDOWREGION IL:EVALV IL:TTY/EDITE IL:CLISPTRAN IL:TTY/EDITL IL:MARKASCHANGED IL:FIXEDITDATE IL:PUTDEF IL:ADDSPELL IL:PROCESS.APPLY IL:STKPOS IL:EDITMODE IL:TOTOPW IL:EXPANDW IL:ADD.PROCESS IL:INSIDEP IL:LASTMOUSEX IL:LASTMOUSEY IL:CREATEW IL:DSPLINEFEED IL:DSPRIGHTMARGIN IL:DOWINDOWCOM IL:TTY.PROCESSP IL:IN/SCROLL/BAR? IL:SCROLL.HANDLER IL:BLOCK IL:CLOCK IL:DSPXOFFSET IL:DSPYOFFSET IL:CREATEREGION IL:HEIGHTIFWINDOW IL:SCROLLW IL:WXOFFSET IL:WYOFFSET IL:KEYDOWNP IL:SHIFTDOWNP IL:UNTILMOUSESTATE IL:FIND-READTABLE IL:NILL IL:FILECOMS IL:ADDFILE IL:ADDTOFILE IL:READTABLEPROP IL:LINELENGTH IL:GETDEF) (IL:* IL:\| "Filecom converters") (IL:FUNCTIONS CONVERT-FNS CONVERT-ONE-FN CONVERT-CONSTANTS CONVERT-INITVARS CONVERT-VARS CONVERT-MACROS CONVERT-ADDVARS CONVERT-APPENDVARS CONVERT-ALISTS CONVERT-PROP CONVERT-PROPS CONVERT-IFPROP CONVERT-RECORDS CONVERT-FILES-FILECOM CONVERT-TOP-LEVEL-FORM-FILECOM CONVERT-COMMENT-FILECOM CONVERT-COMS-FILECOM CONVERT-DECLARE-FILECOM CONVERT-EXPORT-FILECOM CONVERT-FUNCTIONS-FILECOM CONVERT-ONE-BITMAP CONVERT-BITMAPS CONVERT-VARIABLES-FILECOM CONVERT-STRUCTURES-FILECOM) (IL:* IL:|;;| "Conversion functions for filecom types are noted on the plists of their names.") (IL:PROP CONVERT-COM IL:FNS IL:CONSTANTS IL:INITVARS IL:VARS IL:MACROS IL:ADDVARS IL:APPENDVARS IL:ALISTS IL:PROP IL:PROPS IL:IFPROP IL:RECORDS IL:INITRECORDS IL:FILES IL:P IL:* IL:COMS IL:DECLARE\: EXPORT IL:FUNCTIONS IL:VARIABLES IL:STRUCTURES IL:SETFS IL:BITMAPS) (IL:* IL:|;;| "Magic to make comments print out in the usual way...") (IL:STRUCTURES IL-COMMENT-STRUCT) (IL:FUNCTIONS PRINT-IL-COMMENT-STRUCT *) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IL-SIM)) +) + + + +(IL:* IL:|;;| +"Converter macros Have to add \"CL\" as a nickname to the LISP package since some Interlisp code names it that way." +) + + +(IN-PACKAGE (QUOTE IL-CONVERT)) + +(DEFUN CONVERT-TO-STRING (S) (IF (STRINGP S) S (IL:BQUOTE (STRING (IL:\\\, S))))) + +(DEFUN SIMP-MINUS (N) (IF (NUMBERP N) (- N) (IL:BQUOTE (- (IL:\\\, N))))) + +(DEFUN SIMP-1- (N) (IF (NUMBERP N) (1- N) (IL:BQUOTE (1- (IL:\\\, N))))) + +(DEFUN QUOTE-TREE (ARG) (COND ((CONSP ARG) (CONS (QUOTE-TREE (CAR ARG)) (QUOTE-TREE (CDR ARG)))) ((SYMBOLP ARG) (IL:* IL:|;;| "Macros sometimes have (if 'macroarg...) in them.") (IF (EQ (CDR (ASSOC ARG *LOCALS*)) :MACRO-ARG) (MAKE-MACRO-ARG :ELEMENT ARG) (NOTE-EXPORTED-SYMBOL ARG))) (T ARG))) + +(DEFUN EXPAND-VARLIST (VARLST &KEY SEQUENTIAL (TYPE :LOCAL)) (DECLARE (SPECIAL *LOCALS*)) (DO ((VARLST VARLST (REST VARLST)) (*LOCALS* *LOCALS*) (NEW-VARLST NIL) (VARNAMES NIL) VAR VARNAME) ((ENDP VARLST) (VALUES (NREVERSE NEW-VARLST) VARNAMES)) (DECLARE (SPECIAL *LOCALS*)) (SETQ VAR (FIRST VARLST)) (COND ((CONSP VAR) (SETQ VARNAME (FIRST VAR)) (PUSH (IL:BQUOTE ((IL:\\\, VARNAME) (IL:\\\,@ (MAPCONVERT (REST VAR))))) NEW-VARLST)) (T (SETQ VARNAME VAR) (PUSH VAR NEW-VARLST))) (SETQ VARNAME (CONS VARNAME TYPE)) (PUSH VARNAME VARNAMES) (WHEN SEQUENTIAL (PUSH VARNAME *LOCALS*)))) + +(IL-DEFCONV RPAQQ (&REST PAIRS) (DO ((PAIRS PAIRS (REST (REST PAIRS))) SYM (NEWPAIRS NIL)) ((ENDP PAIRS) (IL:BQUOTE (SETQ (IL:\\\,@ (NREVERSE NEWPAIRS))))) (SETQ SYM (CONVERT (FIRST PAIRS))) (PUSH SYM NEWPAIRS) (PUSHNEW SYM *GLOBALS*) (PUSH (CONVERT (IL:BQUOTE (QUOTE (IL:\\\, (SECOND PAIRS))))) NEWPAIRS))) + +(IL-DEFCONV RPAQ (&REST PAIRS) (DO ((PAIRS PAIRS (REST (REST PAIRS))) SYM (NEWPAIRS NIL)) ((ENDP PAIRS) (IL:BQUOTE (SETQ (IL:\\\,@ (NREVERSE NEWPAIRS))))) (SETQ SYM (CONVERT (FIRST PAIRS))) (PUSH SYM NEWPAIRS) (PUSHNEW SYM *GLOBALS*) (PUSH (IL:BQUOTE (IL:\\\, (CONVERT (SECOND PAIRS)))) NEWPAIRS))) + +(IL-DEFCONV RPAQ? (VAR &OPTIONAL (VALUE NIL SVAR) &REST OTHER-ARGS) (DECLARE (IGNORE OTHER-ARGS)) (CHECK-TYPE VAR SYMBOL) (LET ((SYM (CONVERT VAR))) (PUSHNEW SYM *GLOBALS*) (IF SVAR (IL:BQUOTE (DEFVAR (IL:\\\, SYM) (IL:\\\, (CONVERT VALUE)))) (IL:BQUOTE (DEFVAR (IL:\\\, SYM)))))) + +(IL-DEFCONV CONSTANTS (&REST VARS-VALS) (PROGN-IF-NEEDED (MAP (QUOTE LIST) (FUNCTION (LAMBDA (F) (IF (CONSP F) (IL:BQUOTE (DEFCONSTANT (IL:\\\, (CONVERT (CAR F))) (IL:\\\, (CONVERT (CADR F))))) (IL:BQUOTE (DEFCONSTANT (IL:\\\, (CONVERT F)) (IL:\\\, (CONVERT F))))))) VARS-VALS))) + + + +(IL:* IL:\| "chapter 2") + + +(DEFVAR *WARN-FOR-ALL-IL-SYMBOLS* NIL) + +(DEFPARAMETER *WARN-FOR-IL-SYMBOLS-LOWER-THAN-THIS* NIL) + +(DEFVAR *WARN-ON-CHAR-CODE-USE* NIL "Warn if character codes are being used.") + +(IL-COPYDEF ATOM) + +(IL-COPYDEF BOUNDP) + +(IL-COPYDEF SET) + +(IL-DEFCONV LITATOM (X) (IL:* IL:|;;| "A more sophisticated code walker would tell us if this were being used as a test, and we could just expand to SYMBOLP then.") (LET* ((XV (IF (SYMBOLP X) (CONVERT X) (MAKE-FAKE-SYMBOL (QUOTE ..X..)))) (BODY (IL:BQUOTE (AND (SYMBOLP (IL:\\\, XV)) (IL:\\\, XV))))) (IF (SYMBOLP X) BODY (IL:BQUOTE (LET (((IL:\\\, XV) (IL:\\\, (CONVERT X)))) (IL:\\\, BODY)))))) + +(IL-DEFCONV SETQQ (&REST PAIRS) (DO ((PAIRS PAIRS (REST (REST PAIRS))) (NEWPAIRS NIL)) ((ENDP PAIRS) (IL:BQUOTE (SETQ (IL:\\\,@ (NREVERSE NEWPAIRS))))) (PUSH (CONVERT (FIRST PAIRS)) NEWPAIRS) (PUSH (CONVERT (IL:BQUOTE (QUOTE (IL:\\\, (SECOND PAIRS))))) NEWPAIRS))) + +(IL-DEFCONV SETQ (&REST PAIRS) (DO ((PAIRS PAIRS (REST (REST PAIRS))) (NEWPAIRS NIL)) ((ENDP PAIRS) (IL:BQUOTE (SETQ (IL:\\\,@ (NREVERSE NEWPAIRS))))) (PUSH (CONVERT (FIRST PAIRS)) NEWPAIRS) (PUSH (IL:BQUOTE (IL:\\\, (CONVERT (SECOND PAIRS)))) NEWPAIRS))) + +(IL-DEFCONV PSETQ (&REST PAIRS) (DO ((PAIRS PAIRS (REST (REST PAIRS))) (NEWPAIRS NIL)) ((ENDP PAIRS) (IL:BQUOTE (PSETQ (IL:\\\,@ (NREVERSE NEWPAIRS))))) (PUSH (CONVERT (FIRST PAIRS)) NEWPAIRS) (PUSH (IL:BQUOTE (IL:\\\, (CONVERT (SECOND PAIRS)))) NEWPAIRS))) + +(IL-WARNINGFORM IL:GETTOPVAL) + +(IL-WARNINGFORM IL:SETTOPVAL) + + + +(IL:* IL:|;;| "with Franz, might want to use mp:global-symbol-value for the following") + + +(IL-COPYDEF SET SETATOMVAL) + +(IL-DEFCONV GETATOMVAL (VAR) (IL:BQUOTE (SYMBOL-VALUE (IL:\\\, (CONVERT VAR))))) + +(IL-DEFCONV GETPROP (ATM PROP) (IF (QUOTED-SYMBOL-P ATM) (IL:BQUOTE (GET (IL:\\\, (CONVERT ATM)) (IL:\\\, (CONVERT PROP)))) (IL:BQUOTE (AND (SYMBOLP (IL:\\\, (CONVERT ATM))) (GET (IL:\\\, (CONVERT ATM)) (IL:\\\, (CONVERT PROP))))))) + +(IL-DEFCONV PUTPROP (ATM PROP &OPTIONAL VAL) (IL:BQUOTE (SETF (GET (IL:\\\, (CONVERT ATM)) (IL:\\\, (CONVERT PROP))) (IL:\\\, (CONVERT VAL))))) + +(IL-DEFCONV ADDPROP (SYM PROP VAL FRONTP) (LET ((SVAR (MAKE-FAKE-SYMBOL (QUOTE ..S..))) (PVAR (MAKE-FAKE-SYMBOL (QUOTE ..P..))) (XVAR (MAKE-FAKE-SYMBOL (QUOTE ..X..)))) (CASE FRONTP ((T) (IL:BQUOTE (LET* (((IL:\\\, SVAR) (IL:\\\, SYM)) ((IL:\\\, PVAR) (IL:\\\, PROP)) ((IL:\\\, XVAR) (GET SVAR PVAR))) (IF (IL:\\\, XVAR) (NCONC (IL:\\\, XVAR) (IL:\\\, VAL)) (SETF (GET (IL:\\\, SVAR) (IL:\\\, PVAR)) (LIST (IL:\\\, VAL))))))) ((NIL) (IL:BQUOTE (PUSH (IL:\\\, VAL) (GET (IL:\\\, SYM) (IL:\\\, PROP))))) (OTHERWISE (IL:BQUOTE (IF (IL:\\\, FRONTP) (PUSH (IL:\\\, VAL) (GET (IL:\\\, SYM) (IL:\\\, PROP))) (LET* (((IL:\\\, SVAR) (IL:\\\, SYM)) ((IL:\\\, PVAR) (IL:\\\, PROP)) ((IL:\\\, XVAR) (GET (IL:\\\, SVAR) (IL:\\\, PVAR)))) (IF (IL:\\\, XVAR) (NCONC (IL:\\\, XVAR) (IL:\\\, VAL)) (SETF (GET (IL:\\\, SVAR) (IL:\\\, PVAR)) (LIST (IL:\\\, VAL))))))))))) + +(IL-DEFCONV REMPROP (ATM PROP) (IL:BQUOTE (PROGN (REMPROP (IL:\\\, (CONVERT ATM)) (IL:\\\, (CONVERT PROP))) NIL))) + +(IL-DEFCONV REMPROPLIST (ATM PROPS) (LET ((PVAR (MAKE-FAKE-SYMBOL (QUOTE .PROP.)))) (IL:BQUOTE (PROGN (DOLIST ((IL:\\\, PVAR) (IL:\\\, (CONVERT PROPS))) (REMPROP (IL:\\\, (CONVERT ATM)) (IL:\\\, PVAR))) NIL)))) + +(IL-DEFCONV CHANGEPROP (SYM PROP1 PROP2) (LET* ((SYMVAR-UNLETTED (OR (SYMBOLP SYM) (AND (CONSP SYM) (EQ (CAR SYM) (QUOTE QUOTE)) (= (LENGTH SYM) 2)))) (SYMVAR (IF SYMVAR-UNLETTED (CONVERT SYM) (MAKE-FAKE-SYMBOL (QUOTE ..SYM..)))) (BODY (IL:BQUOTE (SETF (GET (IL:\\\, SYMVAR) (IL:\\\, (CONVERT PROP2))) (GET (IL:\\\, SYMVAR) (IL:\\\, (CONVERT PROP1))))))) (IF SYMVAR-UNLETTED BODY (IL:BQUOTE (LET (((IL:\\\, SYMVAR) (IL:\\\, SYM))) (IL:\\\, BODY)))))) + +(IL-WARNINGFORM IL:PROPNAMES) + +(IL-WARNINGFORM IL:DEFLIST) + +(IL-COPYDEF SYMBOL-PLIST GETPROPLIST) + +(IL-COPYDEF GENTEMP GENSYM) + +(IL-DEFCONV MKATOM (X) (WARN "MKATOM translated for strings only.") (IL:BQUOTE (INTERN (IL:\\\, (CONVERT X))))) + +(IL-DEFCONV L-CASE (THING &OPTIONAL FLG) (WARN "L-CASE translated for strings only") (CASE FLG ((T) (IL:BQUOTE (STRING-CAPITALIZE (IL:\\\, (CONVERT THING))))) ((NIL) (IL:BQUOTE (STRING-DOWNCASE (IL:\\\, (CONVERT THING))))) (OTHERWISE (LET ((S (MAKE-FAKE-SYMBOL ".X."))) (IL:BQUOTE (LET (((IL:\\\, S) (IL:\\\, (CONVERT THING)))) "L-CASE" (IF (IL:\\\, (CONVERT FLG)) (STRING-CAPITALIZE (IL:\\\, S)) (STRING-DOWNCASE (IL:\\\, S))))))))) + +(IL-DEFCONV U-CASE (THING) (WARN "U-CASE translated for strings only") (IL:BQUOTE (STRING-UPCASE (IL:\\\, (CONVERT THING))))) + +(IL-DEFCONV SETPROPLIST (ATM LST) (IL:BQUOTE (SETF (SYMBOL-PLIST (IL:\\\, (CONVERT ATM)) (IL:\\\, (CONVERT LST)))))) + +(IL-DEFCONV CHARCODE (CHAR) (BLOCK CHARCODE (FLET ((CONVERT-CHAR (X) (COND ((TYPEP X (QUOTE (INTEGER 0 9))) (DIGIT-CHAR X)) ((EQL (LENGTH (STRING X)) 1) (CHAR (STRING X) 0)) ((AND (EQL (LENGTH (STRING X)) 2) (EQL (CHAR (STRING X) 0) #\^)) (CODE-CHAR (- (CHAR-CODE (CHAR-UPCASE (CHAR (STRING X) 1))) (CHAR-CODE #\@)))) ((NAME-CHAR X)) (T (RETURN-FROM CHARCODE (LIST (CONVERT (QUOTE IL:CHARCODE)) (CONVERT X))))))) (TYPECASE CHAR ((OR STRING SYMBOL (INTEGER 0 9)) (IL:BQUOTE (CHAR-CODE (IL:\\\, (CONVERT-CHAR CHAR))))) (LIST (IL:BQUOTE (MAPCAR (FUNCTION CHAR-CODE) (QUOTE (IL:\\\, (MAPCAR (FUNCTION CONVERT-CHAR) CHAR)))))) (OTHERWISE (LIST (CONVERT (QUOTE CHARCODE)) (CONVERT CHAR))))))) + +(IL-DEFCONV NTHCHARCODE (X N &OPTIONAL FLG RDTBL) (COND ((OR FLG RDTBL) (WARN "Cannot translate NTHCHARCODE flg or rdtbl args") *CURRENT-EXPRESSION*) (T (IL:BQUOTE (CHAR (SYMBOL-NAME (IL:\\\, (CONVERT X))) (IL:\\\, (CONVERT N))))))) + +(IL-DEFCONV CHARACTER (FORM) (IL:BQUOTE (CODE-CHAR (IL:\\\, (CONVERT FORM))))) + +(IL-DEFCONV CHCON1 (FORM) (IL:BQUOTE (CHAR-CODE (SVREF (SYMBOL-NAME (IL:\\\, (CONVERT FORM))) 0)))) + +(DEFUN EVAL-IF-POSSIBLE (X) (XCL:IGNORE-ERRORS (RETURN-FROM EVAL-IF-POSSIBLE (EVAL X))) X) + +(IL-DEFCONV SELCHARQ (KEY &REST CLAUSES &AUX X) (IL:BQUOTE (CASE (IL:\\\, (CONVERT KEY)) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (CLAUSE &AUX X) (CONS (IF (CONSP (SETQ X (CAR CLAUSE))) (MAPCAR (FUNCTION (LAMBDA (V) (EVAL-IF-POSSIBLE (CONVERT (IL:BQUOTE (IL:CHARCODE (IL:\\\, X))))))) X) (AND X (EVAL-IF-POSSIBLE (CONVERT (IL:BQUOTE (IL:CHARCODE (IL:\\\, X))))))) (MAPCONVERT (CDR CLAUSE))))) (BUTLAST CLAUSES))) (IL:\\\,@ (AND (SETQ X (CAR (LAST CLAUSES))) (IL:BQUOTE ((OTHERWISE (IL:\\\,@ (IF (CONSP X) (CONVERT X) (LIST (CONVERT X)))))))))))) + +(IL-COPYCONV CHARACTER FCHARACTER) + +(IL-WARNINGFORM IL:PACK) + +(IL-WARNINGFORM IL:PACK*) + +(IL-WARNINGFORM IL:UNPACK) + +(IL-WARNINGFORM IL:DUNPACK) + +(IL-WARNINGFORM IL:MAPATOMS) + +(IL-WARNINGFORM IL:APROPOS) + + + +(IL:* IL:\; "***** rest of chapter 2") + + + + +(IL:* IL:\| "Chapter 3") + + +(IL-DEFCONV NLISTP (X) (IL:BQUOTE (NOT (LISTP (IL:\\\, (CONVERT X)))))) + + + +(IL:* IL:\; "***** CAR/CDRERR") + + +(IL-COPYDEF CONS) + +(IL-COPYDEF LISTP) + +(IL-COPYDEF CAR) + +(IL-COPYDEF CDR) + +(IL-COPYDEF CADR) + +(IL-COPYDEF CDAR) + +(IL-COPYDEF CDDR) + +(IL-COPYDEF CAAAR) + +(IL-COPYDEF CAADR) + +(IL-COPYDEF CADAR) + +(IL-COPYDEF CADDR) + +(IL-COPYDEF CDAAR) + +(IL-COPYDEF CDADR) + +(IL-COPYDEF CDDAR) + +(IL-COPYDEF CDDDR) + +(IL-COPYDEF CAAAAR) + +(IL-COPYDEF CAAADR) + +(IL-COPYDEF CAADAR) + +(IL-COPYDEF CAADDR) + +(IL-COPYDEF CADAAR) + +(IL-COPYDEF CDDDAR) + +(IL-COPYDEF CDDDDR) + +(IL-COPYDEF RPLACD) + +(IL-COPYDEF RPLACD FRPLACD) + +(IL-COPYDEF RPLACA) + +(IL-COPYDEF RPLACA FRPLACA) + +(IL-DEFCONV RPLNODE (X A D) (IL:BQUOTE (LET (($X$ (IL:\\\, (CONVERT X)))) (RPLACA $X$ (IL:\\\, (CONVERT A))) (RPLACD $X$ (IL:\\\, (CONVERT D)))))) + +(IL-DEFCONV RPLNODE2 (X Y) (LET ((XVAR (MAKE-FAKE-SYMBOL ".X."))) (IL:BQUOTE (LET (((IL:\\\, XVAR) (IL:\\\, (CONVERT X)))) (RPLACA (IL:\\\, XVAR) (CAR (IL:\\\, (CONVERT Y)))) (RPLACD (IL:\\\, XVAR) (CDR (IL:\\\, (CONVERT Y)))))))) + +(IL-DEFCONV FRPLNODE (X A D) (IL:BQUOTE (IL-RPLNODE (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT A)) (IL:\\\, (CONVERT D))))) + +(IL-DEFCONV FRPLNODE2 (X Y) (IL:BQUOTE (LET (($X$ (IL:\\\, (CONVERT X))) ($Y$ (IL:\\\, (CONVERT Y)))) (RPLACA $X$ (CAR $Y$)) (RPLACD $X$ (CDR $Y$)) $X$))) + +(IL-DEFCONV MKLIST (X) (IL:BQUOTE (LET (($X$ (IL:\\\, (CONVERT X)))) (IF (LISTP $X$) $X$ (LIST $X$))))) + +(IL-DEFCONV NCONC1 (LST X) (IL:BQUOTE (NCONC (IL:\\\, (CONVERT LST)) (LIST (IL:\\\, (CONVERT X)))))) + +(IL-COPYDEF LIST) + +(IL-COPYDEF LIST*) + +(IL-COPYDEF APPEND) + +(IL-COPYDEF NCONC) + +(IL-COPYDEF TAILP) + +(IL-COPYDEF LAST) + +(IL-COPYDEF LENGTH) + +(IL-COPYDEF LENGTH FLENGTH) + +(IL-COPYDEF SET-DIFFERENCE LDIFFERENCE) + +(IL-COPYDEF INTERSECTION) + +(IL-COPYDEF UNION) + +(IL-DEFCONV ATTACH (X L) (LET* ((CON-X (CONVERT X)) (CON-L (CONVERT L)) (XV (IF (SYMBOLP CON-X) CON-X (MAKE-FAKE-SYMBOL (QUOTE ..X..)))) (LV (IF (SYMBOLP CON-L) CON-L (MAKE-FAKE-SYMBOL (QUOTE ..L..)))) (BODY (IL:BQUOTE (IF (IL:\\\, LV) (PROGN (SETF (CDR (IL:\\\, LV)) (CONS (CAR (IL:\\\, LV)) (CDR (IL:\\\, LV))) (CAR (IL:\\\, LV)) (IL:\\\, XV)) (IL:\\\, LV)) (CONS (IL:\\\, XV) NIL))))) (IF (AND (SYMBOLP CON-X) (SYMBOLP CON-L)) BODY (IL:BQUOTE (LET ((IL:\\\,@ (UNLESS (SYMBOLP CON-X) (IL:BQUOTE (((IL:\\\, XV) (IL:\\\, CON-X)))))) (IL:\\\,@ (UNLESS (SYMBOLP CON-L) (IL:BQUOTE (((IL:\\\, LV) (IL:\\\, CON-L))))))) (IL:\\\, BODY)))))) + +(IL-DEFCONV LCONC (HEAD THING) (LET ((PV (MAKE-FAKE-SYMBOL ".P."))) (IF (NULL HEAD) (IL:BQUOTE (LET (((IL:\\\, PV) (CONS (IL:\\\, (CONVERT THING)) NIL))) (CONS (IL:\\\, PV) (LAST (IL:\\\, PV))))) (IL:BQUOTE (LET (((IL:\\\, PV) (IL:\\\, (CONVERT HEAD)))) "LCONC" (IF (CONSP (IL:\\\, PV)) (SETF (CDDR (IL:\\\, PV)) (CONS (IL:\\\, (CONVERT THING)) NIL) (CDR (IL:\\\, PV)) (LAST (CDDR (IL:\\\, PV)))) (LET (((IL:\\\, PV) (CONS (IL:\\\, (CONVERT THING)) NIL))) (CONS (IL:\\\, PV) (LAST (IL:\\\, PV)))))))))) + +(IL-DEFCONV TCONC (HEAD THING) (LET ((PV (MAKE-FAKE-SYMBOL ".P."))) (IF (NULL HEAD) (IL:BQUOTE (LET (((IL:\\\, PV) (CONS (IL:\\\, (CONVERT THING)) NIL))) (CONS (IL:\\\, PV) (IL:\\\, PV)))) (IL:BQUOTE (LET (((IL:\\\, PV) (IL:\\\, (CONVERT HEAD)))) "TCONC" (IF (CONSP (IL:\\\, PV)) (SETF (CDDR (IL:\\\, PV)) (CONS (IL:\\\, (CONVERT THING)) NIL) (CDR PV) (CDDR PV)) (LET (((IL:\\\, PV) (CONS (IL:\\\, (CONVERT THING)) NIL))) (CONS (IL:\\\, PV) (IL:\\\, PV))))))))) + +(IL-WARNINGFORM IL:DOCOLLECT) + +(IL-WARNINGFORM IL:ENDCOLLECT) + +(IL-WARNINGFORM IL:SCRATCHLIST) + +(IL-WARNINGFORM IL:ADDTOSCRATCHLIST) + +(IL-WARNINGFORM IL:COPYALL) + +(IL-WARNINGFORM IL:HCOPYALL) + +(IL-WARNINGFORM IL:NLEFT) + +(IL-WARNINGFORM IL:LASTN) + +(IL-WARNINGFORM IL:COUNT) + +(IL-WARNINGFORM IL:COUNTDOWN) + +(IL-WARNINGFORM IL:EQUALN) + +(IL-WARNINGFORM IL:LDIFF) + +(IL-WARNINGFORM IL:LSUBST) + +(IL-WARNINGFORM IL:SUBPAIR) + + + +(IL:* IL:\; "warning forms ") + + +(IL-COPYDEF COPY-LIST COPY) + +(IL-DEFCONV NTH (X N) (IL:BQUOTE (NTHCDR (1- (IL:\\\, (CONVERT N))) (IL:\\\, (CONVERT X))))) + +(IL-DEFCONV MEMB (X Y) (IL:BQUOTE (MEMBER (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y)) :TEST (FUNCTION EQ)))) + +(IL-DEFCONV FMEMB (X Y) (IL:BQUOTE (MEMBER (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y)) :TEST (FUNCTION EQ)))) + +(IL-DEFCONV MEMBER (X Y) (IL:BQUOTE (MEMBER (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y)) :TEST (FUNCTION EQUAL)))) + +(IL-DEFCONV EQMEMB (X Y) (LET ((XV (MAKE-FAKE-SYMBOL (QUOTE .X.))) (YV (MAKE-FAKE-SYMBOL (QUOTE .Y.)))) (IL:BQUOTE (LET (((IL:\\\, XV) (IL:\\\, (CONVERT X))) ((IL:\\\, YV) (IL:\\\, (CONVERT Y)))) "IL:EQMEMB" (OR (EQ (IL:\\\, XV) (IL:\\\, YV)) (MEMBER (IL:\\\, XV) (IL:\\\, YV) :TEST (FUNCTION EQ))))))) + +(IL-DEFCONV SUBST (NEW OLD EXPR) (IL:BQUOTE (SUBST (IL:\\\, (CONVERT NEW)) (IL:\\\, (CONVERT OLD)) (IL:\\\, (CONVERT EXPR)) :TEST (FUNCTION EQUAL)))) + +(IL-DEFCONV DSUBST (NEW OLD EXPR) (IL:BQUOTE (NSUBST (IL:\\\, (CONVERT NEW)) (IL:\\\, (CONVERT OLD)) (IL:\\\, (CONVERT EXPR)) :TEST (FUNCTION EQUAL)))) + +(IL-DEFCONV SUBLIS (ALST EXPR FLG) (COND ((EQ FLG (QUOTE T)) (IL:BQUOTE (SUBLIS (IL:\\\, (CONVERT ALST)) (COPY-TREE (IL:\\\, (CONVERT EXPR)))))) ((NULL FLG) (IL:BQUOTE (SUBLIS (IL:\\\, (CONVERT ALST)) (IL:\\\, (CONVERT EXPR))))) (T (IL:BQUOTE (SUBLIS (IL:\\\, (CONVERT ALST)) (IF (IL:\\\, (CONVERT FLG)) (COPY-TREE (IL:\\\, (CONVERT EXPR))) (IL:\\\, (CONVERT EXPR)))))))) + +(IL-DEFCONV DSUBLIS (ALST EXPR FLG) (COND ((EQ FLG (QUOTE T)) (IL:BQUOTE (NSUBLIS (IL:\\\, (CONVERT ALST)) (COPY-TREE (IL:\\\, (CONVERT EXPR)))))) ((NULL FLG) (IL:BQUOTE (NSUBLIS (IL:\\\, (CONVERT ALST)) (IL:\\\, (CONVERT EXPR))))) (T (IL:BQUOTE (NSUBLIS (IL:\\\, (CONVERT ALST)) (IF (IL:\\\, (CONVERT FLG)) (COPY-TREE (IL:\\\, (CONVERT EXPR))) (IL:\\\, (CONVERT EXPR)))))))) + +(IL-DEFCONV ASSOC (KEY ALST) (IL:BQUOTE (ASSOC (IL:\\\, (CONVERT KEY)) (IL:\\\, (CONVERT ALST)) :TEST (FUNCTION EQ)))) + +(IL-DEFCONV SASSOC (KEY ALST) (IL:BQUOTE (ASSOC (IL:\\\, (CONVERT KEY)) (IL:\\\, (CONVERT ALST)) :TEST (FUNCTION EQUAL)))) + +(IL-DEFCONV PUTASSOC (KEY VAL ALST) (LET ((AVAR (MAKE-FAKE-SYMBOL (QUOTE .ALIST.))) (KVAR (MAKE-FAKE-SYMBOL (QUOTE .KEY.))) (CVAR (MAKE-FAKE-SYMBOL (QUOTE .ASSN.)))) (IL:BQUOTE (LET* (((IL:\\\, KVAR) (IL:\\\, (CONVERT KEY))) ((IL:\\\, CVAR) (ASSOC (IL:\\\, KVAR) (IL:\\\, AVAR)))) "IL:PUTASSOC" (IF (IL:\\\, CVAR) (SETF (CDR (IL:\\\, CVAR)) (IL:\\\, (CONVERT VAL))) (IF (CONSP (IL:\\\, AVAR)) (NCONC (IL:\\\, AVAR) (CONS (CONS (IL:\\\, KVAR) (IL:\\\, (CONVERT VAL))) NIL)))))))) + +(IL-COPYCONV NTH FNTH) + +(IL-COPYCONV LAST FLAST) + +(IL-COPYCONV MEMB FMEMB) + +(IL-COPYCONV ASSOC FASSOC) + +(IL-COPYDEF GETF LISTGET) + +(IL-DEFCONV LISTPUT (LST PROP VAL) (IL:BQUOTE (SETF (GETF (IL:\\\, (CONVERT LST)) (IL:\\\, (CONVERT PROP))) (IL:\\\, (CONVERT VAL))))) + +(IL-DEFCONV LISTGET1 (LST PROP) (IL:BQUOTE (SECOND (MEMBER (IL:\\\, (CONVERT PROP)) (IL:\\\, (CONVERT LST)) :TEST (FUNCTION EQ))))) + +(IL-DEFCONV MERGE (A B COMPAREFN) (IL:BQUOTE (MERGE (QUOTE LIST) (IL:\\\, (CONVERT A)) (IL:\\\, (CONVERT B)) (IL:\\\, (CONVERT COMPAREFN))))) + +(IL-WARNINGFORM IL:LISTPUT1) + +(IL-WARNINGFORM IL:ALPHORDER) + +(IL-WARNINGFORM IL:UALPHORDER) + +(IL-WARNINGFORM IL:COMPARELISTS) + + + +(IL:* IL:\; "warning forms") + + +(IL-DEFCONV REMOVE (X L) (IL:BQUOTE (REMOVE (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT L)) :TEST (FUNCTION EQUAL)))) + +(IL-DEFCONV DREMOVE (X L) (IL:BQUOTE (DELETE (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT L)) :TEST (FUNCTION EQ)))) + +(IL-DEFCONV REVERSE (L) (LET ((LVAR (MAKE-FAKE-SYMBOL ".L."))) (IL:BQUOTE (LET (((IL:\\\, LVAR) (IL:\\\, (CONVERT L)))) (IF (LISTP (IL:\\\, LVAR)) (REVERSE (IL:\\\, LVAR)) (IL:\\\, LVAR)))))) + +(IL-DEFCONV DREVERSE (L) (IL:BQUOTE (IF (LISTP (IL:\\\, L)) (NREVERSE (IL:\\\, L)) (IL:\\\, L)))) + +(IL-DEFCONV NEGATE (X) (IL:BQUOTE (NOT (IL:\\\, (CONVERT X))))) + + + +(IL:* IL:\| "chapter 4") + + +(IL-COPYDEF STRINGP) + +(IL-DEFCONV STREQUAL (X Y) (LET* ((XVARP (NOT (OR (STRINGP X) (SYMBOLP X)))) (YVARP (NOT (OR (STRINGP Y) (SYMBOLP Y)))) (XV (IF XVARP (MAKE-FAKE-SYMBOL "$X") (CONVERT X))) (YV (IF YVARP (MAKE-FAKE-SYMBOL "$Y") (CONVERT Y)))) (IF (OR XVARP YVARP) (IL:BQUOTE (LET ((IL:\\\,@ (AND XVARP (IL:BQUOTE (((IL:\\\, XV) (IL:\\\, (CONVERT X))))))) (IL:\\\,@ (AND YVARP (IL:BQUOTE (((IL:\\\, YV) (IL:\\\, (CONVERT Y)))))))) "IL:STREQUAL" (AND (IL:\\\,@ (IF (NOT (STRINGP X)) (IL:BQUOTE ((STRINGP (IL:\\\, XV)))))) (IL:\\\,@ (IF (NOT (STRINGP Y)) (IL:BQUOTE ((STRINGP (IL:\\\, YV)))))) (STRING= (IL:\\\, XV) (IL:\\\, YV))))) (IL:BQUOTE (STRING= (IL:\\\, XV) (IL:\\\, YV)))))) + +(IL-DEFCONV STRING-EQUAL (X Y) (LET* ((XVARP (NOT (OR (STRINGP X) (SYMBOLP X)))) (YVARP (NOT (OR (STRINGP Y) (SYMBOLP Y)))) (XV (IF XVARP (MAKE-FAKE-SYMBOL "$X") (CONVERT X))) (YV (IF YVARP (MAKE-FAKE-SYMBOL "$Y") (CONVERT Y)))) (IF (OR XVARP YVARP) (IL:BQUOTE (LET ((IL:\\\,@ (AND XVARP (IL:BQUOTE (((IL:\\\, XV) (IL:\\\, (CONVERT X))))))) (IL:\\\,@ (AND YVARP (IL:BQUOTE (((IL:\\\, YV) (IL:\\\, (CONVERT Y)))))))) "IL:STREQUAL" (AND (IL:\\\,@ (IF (NOT (STRINGP X)) (IL:BQUOTE ((STRINGP (IL:\\\, XV)))))) (IL:\\\,@ (IF (NOT (STRINGP Y)) (IL:BQUOTE ((STRINGP (IL:\\\, YV)))))) (STRING= (IL:\\\, XV) (IL:\\\, YV))))) (IL:BQUOTE (STRING-EQUAL (IL:\\\, XV) (IL:\\\, YV)))))) + +(IL-DEFCONV NCHARS (THING &OPTIONAL FLG) (DECLARE (IGNORE FLG)) (IL:* IL:|;;| "Assume it will be a string or symbol; most common case by far.") (IL:BQUOTE (LENGTH (STRING (IL:\\\, (CONVERT THING)))))) + +(DEFUN ALLOCSTRING (N &OPTIONAL INITCHAR OLD FATFLG) (COND (OLD (WARN "Cannot convert ALLOCSTRING old argument") *CURRENT-EXPRESSION*) (T (IL:BQUOTE (MAKE-STRING (IL:\\\, (CONVERT N)) (IL:\\\,@ (IF INITCHAR (LIST :INITIAL-ELEMENT (CONVERT INITCHAR)) NIL))))))) + +(IL-DEFCONV MKSTRING (X &OPTIONAL FLG RDTBL) (IL:BQUOTE (WRITE-TO-STRING (IL:\\\, (CONVERT X)) :ESCAPE (IL:\\\, (CONVERT FLG))))) + +(IL-DEFCONV CONCAT (&REST XX) (IL:BQUOTE (CONCATENATE (QUOTE STRING) (IL:\\\,@ (MAPCONVERT XX))))) + +(IL-DEFCONV CONCATLIST (L) (IL:BQUOTE (APPLY (FUNCTION CONCATENATE) (QUOTE STRING) (MAPCAR (FUNCTION (LAMBDA (X) (PRINC-TO-STRING X))) (IL:\\\, (CONVERT L)))))) + +(IL-DEFCONV RPLSTRING (X N Y) (IL:BQUOTE (REPLACE (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y)) :START1 (IL:\\\, (CONVERT N))))) + +(IL-DEFCONV RPLCHARCODE (X N CODE) (IL:BQUOTE (SETF (CHAR (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT N))) (CODE-CHAR (IL:\\\, (CONVERT CODE)))))) + +(IL-DEFCONV STRPOS (PAT STRING &OPTIONAL START SKIP ANCHOR TAIL CASEARRAY BACKWARDSFLG) (WHEN CASEARRAY (WARN "CASEARRAY arg to STRPOS not translated.")) (WHEN ANCHOR (WARN "ANCHOR arg to STRPOS not translated.")) (WHEN TAIL (WARN "TAIL arg to STRPOS not translated.")) (WHEN SKIP (WARN "SKIP arg to STRPOS not translated.")) (IL:BQUOTE (SEARCH (IL:\\\, (CONVERT PAT)) (IL:\\\, (CONVERT STRING)) (IL:\\\,@ (AND START (IL:BQUOTE (:START2 (1- (IL:\\\, (CONVERT START))))))) (IL:\\\,@ (AND BACKWARDSFLG (IL:BQUOTE (:FROM-END-P (IL:\\\, (CONVERT BACKWARDSFLG))))))))) + +(IL-DEFCONV SUBSTRING (X N &OPTIONAL M OLDPTR) (IL:BQUOTE (SUBSEQ (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT N)) (IL:\\\, (CONVERT M))))) + + + +(IL:* IL:|;;| " Warning Forms") + + +(IL-WARNINGFORM IL:GNC) + +(IL-WARNINGFORM IL:GLC) + + + +(IL:* IL:\| "chapter 5") + + + + +(IL:* IL:\; "***** chapter 5 (arrays)") + + + + +(IL:* IL:\| "chapter 6") + + +(IL-DEFCONV MAPHASH (HARRAY MAPHFN) (IF (AND (CONSP MAPHFN) (EQ (CAR MAPHFN) (QUOTE FUNCTION)) (CONSP (SECOND MAPHFN)) (EQ (CAR (SECOND MAPHFN)) (QUOTE LAMBDA))) (IL:BQUOTE (MAPHASH (FUNCTION (LAMBDA ((IL:\\\, (CONVERT (SECOND (SECOND (SECOND MAPHFN))))) (IL:\\\, (CONVERT (FIRST (SECOND (SECOND MAPHFN)))))) IL:\\\, (MAPCONVERT (CDDR (SECOND MAPHFN))))) (IL:\\\, (CONVERT HARRAY)))) (IF (AND (CONSP MAPHFN) (EQ (CAR MAPHFN) (QUOTE LAMBDA))) (IL:BQUOTE (MAPHASH (FUNCTION (LAMBDA ((IL:\\\, (CONVERT (SECOND (SECOND MAPHFN)))) (IL:\\\, (CONVERT (FIRST (SECOND MAPHFN))))) IL:\\\, (MAPCONVERT (CDDR MAPHFN)))))) (IL:BQUOTE (MAPHASH (FUNCTION (LAMBDA (KEY VAL) (FUNCALL (IL:\\\, (CONVERT MAPHFN)) VAL KEY))) (IL:\\\, (CONVERT HARRAY))))))) + +(IL-DEFCONV GETHASH (KEY &OPTIONAL TABLE) (IL:BQUOTE ((IL:\\\, (IF TABLE (QUOTE GETHASH) (CONVERT (QUOTE GETHASH)))) (IL:\\\, (CONVERT KEY)) (IL:\\\,@ (AND TABLE (LIST (CONVERT TABLE))))))) + +(IL-DEFCONV PUTHASH (KEY VAL &OPTIONAL TBL) (IF TBL (IL:BQUOTE (SETF (GETHASH (IL:\\\, (CONVERT KEY)) (IL:\\\, (CONVERT TBL))) (IL:\\\, (CONVERT VAL)))) (LIST (CONVERT (QUOTE PUTHASH)) (CONVERT VAL) (CONVERT KEY)))) + + + +(IL:* IL:\; "***** chapter 6 (hash arrays)") + + + + +(IL:* IL:\| "chapter 7") + + +(IL-DEFCONV SMALLP (X) (DECLARE (IGNORE X)) NIL) + + + +(IL:* IL:\; "*** ??") + + +(IL-DEFCONV FIXP (X) (IL:BQUOTE (INTEGERP (IL:\\\, (CONVERT X))))) + +(IL-COPYDEF FLOATP) + +(IL-COPYDEF NUMBERP) + +(IL-COPYDEF EQUALP EQP) + + + +(IL:* IL:|;;| "(il-defconv EQP (x y) `(eql ,^x ,^y)) ***** overflow") + + +(IL-DEFCONV PLUS (&REST ARGS) (IL:BQUOTE (+ (IL:\\\,@ (MAPCONVERT ARGS))))) + +(IL-DEFCONV MINUS (X) (IL:BQUOTE (- (IL:\\\, (CONVERT X))))) + +(IL-DEFCONV DIFFERENCE (X Y) (IL:BQUOTE (- (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) + +(IL-DEFCONV TIMES (&REST ARGS) (IL:BQUOTE (* (IL:\\\,@ (MAPCONVERT ARGS))))) + + + +(IL:* IL:\; "***** remainder ") + + +(IL-DEFCONV GREATERP (X Y) (IL:BQUOTE (> (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) + +(IL-DEFCONV LESSP (X Y) (IL:BQUOTE (< (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) + +(IL-DEFCONV GEQ (X Y) (IL:BQUOTE (>= (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) + +(IL-DEFCONV LEQ (X Y) (IL:BQUOTE (<= (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) + +(IL-COPYDEF ZEROP) + +(IL-COPYDEF MINUSP) + +(IL-COPYDEF MIN) + +(IL-COPYDEF MAX) + +(IL-COPYDEF ABS) + + + +(IL:* IL:\; "***** min.integer,^ max.integer") + + +(IL-DEFCONV IPLUS (&REST ARGS) (IL:BQUOTE (+ (IL:\\\,@ (MAPCONVERT ARGS))))) + +(IL-DEFCONV IMINUS (&REST ARGS) (IL:BQUOTE (- (IL:\\\,@ (MAPCONVERT ARGS))))) + +(IL-DEFCONV IDIFFERENCE (X Y) (IL:BQUOTE (- (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) + +(IL-DEFCONV ADD1 (X) (IL:BQUOTE (1+ (IL:\\\, (CONVERT X))))) + +(IL-DEFCONV SUB1 (X) (IL:BQUOTE (1- (IL:\\\, (CONVERT X))))) + +(IL-DEFCONV ITIMES (&REST ARGS) (IL:BQUOTE (* (IL:\\\,@ (MAPCONVERT ARGS))))) + +(IL-DEFCONV IQUOTIENT (X Y) (IL:BQUOTE (TRUNCATE (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) + +(IL-DEFCONV IREMAINDER (X Y) (IL:BQUOTE (REM (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) + +(IL-DEFCONV IMOD (X Y) (IL:BQUOTE (MOD (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) + +(IL-DEFCONV IGREATERP (X Y) (IL:BQUOTE (> (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) + +(IL-DEFCONV ILESSP (X Y) (IL:BQUOTE (< (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) + +(IL-DEFCONV IGEQ (X Y) (IL:BQUOTE (>= (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) + +(IL-DEFCONV ILEQ (X Y) (IL:BQUOTE (<= (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) + +(IL-DEFCONV IMIN (&REST ARGS) (IL:BQUOTE (MIN (IL:\\\,@ (MAPCONVERT ARGS))))) + +(IL-DEFCONV IMAX (&REST ARGS) (IL:BQUOTE (MAX (IL:\\\,@ (MAPCONVERT ARGS))))) + +(IL-DEFCONV IEQP (X Y) (IL:BQUOTE (EQL (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) + +(IL-DEFCONV FIX (N) (IL:BQUOTE (TRUNCATE (IL:\\\, (CONVERT N))))) + +(IL-DEFCONV FIXR (N) (IL:BQUOTE (ROUND (IL:\\\, (CONVERT N))))) + +(IL-DEFCONV RSH (X N) (IL:BQUOTE (ASH (IL:\\\, (CONVERT X)) (IL:\\\, (SIMP-MINUS (CONVERT N)))))) + +(IL-DEFCONV POWEROFTWOP (X) (IL:BQUOTE (= (LOGCOUNT (IL:\\\, (CONVERT X))) 1))) + +(IL-DEFCONV EVENP (X &OPTIONAL (Y 2)) (IL:BQUOTE (ZEROP (MOD (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y)))))) + +(IL-DEFCONV ODDP (X &OPTIONAL (Y 2)) (IL:BQUOTE (NOT (ZEROP (MOD (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))))) + +(IL-DEFCONV BITTEST (N MASK) (IL:BQUOTE (NOT (= 0 (LOGAND (IL:\\\, (CONVERT N)) (IL:\\\, (CONVERT MASK))))))) + +(IL-DEFCONV BITCLEAR (N MASK) (IL:BQUOTE (LOGAND (IL:\\\, (CONVERT N)) (LOGNOT (IL:\\\, (CONVERT MASK)))))) + +(IL-COPYDEF GCD) + +(IL-COPYDEF LOGAND) + +(IL-COPYDEF LOGIOR LOGOR) + +(IL-COPYDEF ASH LSH) + +(IL-COPYDEF INTEGER-LENGTH INTEGERLENGTH) + +(IL-COPYDEF LOGNOT) + +(IL-COPYDEF LOGIOR BITSET) + +(IL-DEFCONV MASK.1\'S (POSITION SIZE) (IL:BQUOTE (ASH (1- (EXPT 2 (IL:\\\, (CONVERT SIZE)))) (IL:\\\, (CONVERT POSITION))))) + +(IL-DEFCONV MASK.0\'S (POSITION SIZE) (IL:BQUOTE (LOGNOT (ASH (1- (EXPT 2 (IL:\\\, (CONVERT SIZE)))) (IL:\\\, (CONVERT POSITION)))))) + +(IL-DEFCONV LOADBYTE (N POS SIZE) (IL:BQUOTE (LDB (BYTE (IL:\\\, (CONVERT SIZE)) (IL:\\\, (CONVERT POS))) (IL:\\\, (CONVERT N))))) + +(IL-DEFCONV DEPOSITBYTE (N POS SIZE VAL) (IL:BQUOTE (DPB (IL:\\\, (CONVERT VAL)) (BYTE (IL:\\\, (CONVERT SIZE)) (IL:\\\, (CONVERT POS))) (IL:\\\, (CONVERT N))))) + +(IL-COPYDEF BYTE) + +(IL-COPYDEF BYTE-SIZE BYTESIZE) + +(IL-COPYDEF BYTE-POSITION BYTEPOSITION) + +(IL-COPYDEF LDB) + +(IL-COPYDEF DPB) + +(IL-WARNINGFORM IL:ROT) + + + +(IL:* IL:|;;| " *** section 7.4 (floating point)") + + + + +(IL:* IL:\| "chapter 8") + + + + +(IL:* IL:|;;| " **** Record stuff in IL-RECORD.lisp *** Changetran...") + + +(IL-DEFCONV |push| (PLACE VALUE) (IL:BQUOTE (PUSH (IL:\\\, (CONVERT VALUE)) (IL:\\\, (CONVERT PLACE))))) + +(IL-DEFCONV |add| (PLACE &OPTIONAL INCREMENT &REST MORE-INCREMENTS) (COND (MORE-INCREMENTS (IL:BQUOTE (INCF (IL:\\\, (CONVERT PLACE)) (+ (IL:\\\, (CONVERT INCREMENT)) (IL:\\\,@ (MAPCONVERT MORE-INCREMENTS)))))) (INCREMENT (IL:BQUOTE (INCF (IL:\\\, (CONVERT PLACE)) (IL:\\\, (CONVERT INCREMENT))))) (T (CONVERT PLACE)))) + +(IL-DEFCONV |change| (PLACE FORM) (COND ((OR (ATOM PLACE) (AND (= (LENGTH PLACE) 2) (ATOM (SECOND PLACE)))) (IL:BQUOTE (SETF (IL:\\\, (CONVERT PLACE)) (IL:\\\, (CONVERT (IL:SUBPAIR (QUOTE IL:DATUM) PLACE FORM)))))) ((= (LENGTH PLACE) 2) (LET ((NEW-PLACE (LIST (FIRST PLACE) (QUOTE $PLACE-ARG$)))) (IL:BQUOTE (LET (($PLACE-ARG$ (IL:\\\, (SECOND PLACE)))) (SETF (IL:\\\, (CONVERT NEW-PLACE)) (IL:\\\, (CONVERT (IL:SUBPAIR (QUOTE IL:DATUM) NEW-PLACE FORM)))))))) (T (IL:BQUOTE (SETF (IL:\\\, (CONVERT PLACE)) (IL:\\\, (CONVERT (IL:SUBPAIR (QUOTE IL:DATUM) PLACE FORM)))))))) + +(IL-DEFCONV |pushnew| (PLACE THING) (IL:BQUOTE (PUSHNEW (IL:\\\, (CONVERT THING)) (IL:\\\, (CONVERT PLACE)) :TEST (QUOTE EQ)))) + +(IL-DEFCONV |pushlist| (PLACE &REST LISTS) (LET ((NEWPLACE (CONVERT PLACE))) (IL:BQUOTE (SETF (IL:\\\, NEWPLACE) (APPEND (IL:\\\,@ (MAPCONVERT LISTS)) (IL:\\\, NEWPLACE)))))) + +(IL-DEFCONV |swap| (PLACE1 PLACE2) (IL:BQUOTE (ROTATEF (IL:\\\, (CONVERT PLACE1)) (IL:\\\, (CONVERT PLACE2))))) + +(IL-COPYCONV |push| PUSH) + +(IL-COPYCONV |add| ADD) + +(IL-COPYCONV |change| CHANGE) + +(IL-COPYCONV |pushnew| PUSHNEW) + +(IL-COPYCONV |pushlist| PUSHLIST) + +(IL-COPYCONV |swap| SWAP) + +(IL-COPYDEF POP) + +(IL-COPYDEF POP |pop|) + + + +(IL:* IL:\| "chapter 9") + + + + +(IL:* IL:\; "**** 9.1") + + +(IL-COPYDEF EQ) + +(IL-COPYDEF NULL) + +(IL-COPYDEF NOT) + +(IL-COPYDEF EQUAL) + +(IL-COPYDEF AND) + +(IL-COPYDEF OR) + +(IL-DEFCONV NEQ (X Y) (IL:BQUOTE (NOT (EQ (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y)))))) + + + +(IL:* IL:\; "EQP is in chapter 7") + + + + +(IL:* IL:\; "***** EQUALALL") + + +(IL-DEFCONV COND (&REST CLAUSES) (IL:BQUOTE (COND (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (CLAUSE) (MAPCONVERT CLAUSE))) CLAUSES))))) + + + +(IL:* IL:|;;| " (convert '(il:cond ((il:geq 3 2) (il:times 2 3))))") + + +(IL-DEFCONV |if| (&REST ARGS &AUX (FORM (LIST (QUOTE COND)))) (IL:* IL:|;;| "don't use '(cond) because nreverse will smash it") (DO ((CLAUSE (LIST (CONVERT (POP ARGS)))) ARG) ((ENDP ARGS) (WHEN CLAUSE (PUSH (NREVERSE CLAUSE) FORM))) (CASE (SETQ ARG (POP ARGS)) ((IL:|then| IL:THEN)) ((IL:ELSE IL:|else|) (PUSH (NREVERSE CLAUSE) FORM) (SETQ CLAUSE (LIST (QUOTE T)))) (IL:* IL:|;;| "don't use '(t) because nreverse will smash it") ((IL:ELSEIF IL:|elseif|) (PUSH (NREVERSE CLAUSE) FORM) (SETQ CLAUSE (LIST (CONVERT (POP ARGS))))) (OTHERWISE (PUSH (CONVERT ARG) CLAUSE)))) (NREVERSE FORM)) + +(IL-COPYCONV |if| IF) + + + +(IL:* IL:|;;| +" +(convert '(il:|if| (il:geq a b) il:|then| (foo) + il:|elseif| (il:atom (il:plus 2 3)) il:|then| (bar) + il:|else| (baz))) +") + + +(IL-DEFCONV SELECTQ (X &REST CLAUSES) (IL:BQUOTE (CASE (IL:\\\, (CONVERT X)) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (CLAUSE) (IL:BQUOTE ((IL:\\\, (QUOTE-TREE (FIRST CLAUSE))) (IL:\\\,@ (MAPCONVERT (REST CLAUSE))))))) (BUTLAST CLAUSES))) (OTHERWISE (IL:\\\,@ (MAPCONVERT (LAST CLAUSES))))))) + +(IL-DEFCONV SELECTC (X &REST CLAUSES) (LET* ((DATUM (IF (SYMBOLP X) (CONVERT X) (GENTEMP))) (MAINBODY (IL:BQUOTE (COND (IL:\\\,@ (MAP (QUOTE LIST) (FUNCTION (LAMBDA (CLAUSE) (IL:BQUOTE ((EQL (IL:\\\, DATUM) (IL:\\\, (CONVERT (FIRST CLAUSE)))) (IL:\\\,@ (MAPCONVERT (REST CLAUSE))))))) (BUTLAST CLAUSES))) (T (IL:\\\,@ (MAPCONVERT (LAST CLAUSES)))))))) (IF (SYMBOLP X) MAINBODY (IL:BQUOTE (LET (((IL:\\\, DATUM) (IL:\\\, (CONVERT X)))) (IL:\\\, MAINBODY)))))) + +(IL-DEFCONV CASE (X &REST CLAUSES) (IL:BQUOTE (CASE (IL:\\\, (CONVERT X)) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (CLAUSE) (IL:BQUOTE ((IL:\\\, (QUOTE-TREE (FIRST CLAUSE))) (IL:\\\,@ (MAPCONVERT (REST CLAUSE))))))) CLAUSES))))) + + + +(IL:* IL:|;;| " +(convert '(il:selectq (il:plus 2 3) (a (il:times a b)) (il:plus c d))) +") + + + + +(IL:* IL:\; "***** SELECTC") + + +(IL-COPYDEF PROG1) + +(IL-COPYDEF PROG2) + +(IL-COPYDEF PROGN) + +(IL-COPYDEF RETURN) + +(IL-COPYDEF RETURN-FROM RETFROM) + + + +(IL:* IL:|;;| +"If we were really clever we could keep track of when we were inside a PROG. Then we could treat (top-level) symbols as prog labels and not put them in the IL package. In that case we would want GO to generate `(go ,tag) instead of `(go ,^tag)." +) + + +(IL-DEFCONV GO (TAG) (IL:BQUOTE (GO (IL:\\\, (CONVERT TAG))))) + +(IL-DEFCONV PROG (VARLST &REST FORMS) (DECLARE (SPECIAL *LOCALS*)) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST) (IL:BQUOTE (PROG (IL:\\\, NEW-VARLST) (IL:\\\,@ (LET ((*LOCALS* (APPEND VARNAMES *LOCALS*))) (MAPCONVERT FORMS))))))) + +(IL-DEFCONV LET (VARLST &REST FORMS) (DECLARE (SPECIAL *LOCALS*)) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST) (IL:BQUOTE (LET (IL:\\\, NEW-VARLST) (IL:\\\,@ (LET ((*LOCALS* (APPEND VARNAMES *LOCALS*))) (MAPCONVERT FORMS))))))) + +(IL-DEFCONV LET* (VARLST &REST FORMS) (DECLARE (SPECIAL *LOCALS*)) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST :SEQUENTIAL T) (IL:BQUOTE (LET* (IL:\\\, NEW-VARLST) (IL:\\\,@ (LET ((*LOCALS* (APPEND VARNAMES *LOCALS*))) (MAPCONVERT FORMS))))))) + +(IL-DEFCONV PROG* (VARLST &REST FORMS) (DECLARE (SPECIAL *LOCALS*)) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST :SEQUENTIAL T) (IL:BQUOTE (PROG* (IL:\\\, NEW-VARLST) (IL:\\\,@ (LET ((*LOCALS* (APPEND VARNAMES *LOCALS*))) (MAPCONVERT FORMS))))))) + +(DEFUN CONVERT-DO (BINDINGS END-CLAUSES &REST BODY) (DECLARE (SPECIAL *LOCALS*)) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST BINDINGS) (LET ((*LOCALS* (APPEND VARNAMES *LOCALS*))) (IL:BQUOTE (DO (IL:\\\, NEW-VARLST) (IL:\\\,@ (MAPCONVERT END-CLAUSES)) (IL:\\\,@ (MAPCONVERT BODY))))))) + +(DEFUN CONVERT-DO* (BINDINGS END-CLAUSES &REST BODY) (DECLARE (SPECIAL *LOCALS*)) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST BINDINGS) (LET ((*LOCALS* (APPEND VARNAMES *LOCALS*))) (IL:BQUOTE (DO* (IL:\\\, NEW-VARLST) (IL:\\\,@ (MAPCONVERT END-CLAUSES)) (IL:\\\,@ (MAPCONVERT BODY))))))) + +(IL:* IL:|;;| "One case where il-defconv won't do what we need...") + +(SETF (GET (QUOTE DO) (QUOTE CONVERT-FORM)) (QUOTE CONVERT-DO) (GET (QUOTE DO*) (QUOTE CONVERT-FORM)) (QUOTE CONVERT-DO*)) + + + +(IL:* IL:|;;| "I.S. stuff - entry is coded into CONVERT") + + +(DEFPARAMETER *ITERATION-CONVERSION-TABLE* (QUOTE ((IL:|for| ((:EXPR-OR-ASSIGNMENT ((IL:|in| :EXPR ((IL:|by| FILTER-LIST-BY) (T . T))) (IL:|on| :EXPR ((IL:|by| FILTER-LIST-BY) (T . T))) (IL:|from| :EXPR ((IL:|to| :EXPR ((IL:|by| :EXPR T) (T . T))) (T . T))) (IL:|to| :EXPR ((IL:|by| :EXPR T) (T . T)) (T . T)) (IL:|by| (THEN) :EXPR T) (IL:|instring| FILTER-INSTRING))))) (IL:|as| ((:EXPR-OR-ASSIGNMENT ((IL:|in| :EXPR ((IL:|by| FILTER-LIST-BY) (T . T))) (IL:|on| :EXPR ((IL:|by| FILTER-LIST-BY) (T . T))) (IL:|from| :EXPR ((IL:|to| :EXPR ((IL:|by| :EXPR T) (T . T))) (T . T))) (IL:|to| :EXPR ((IL:|by| :EXPR T) (T . T)) (T . T)) (IL:|by| :EXPR T) (IL:|instring| FILTER-INSTRING))))) (IL:|to| (REPEAT) :EXPR ((IL:|by| :EXPR T) (T . T))) (IL:|bind| FILTER-BIND) (IL:|collect| FILTER-DO) (IL:|repeatwhile| FILTER-REPEATWHILE/UNTIL) (IL:|repeatuntil| FILTER-REPEATWHILE/UNTIL) (IL:|while| :EXPR T) (IL:|until| :EXPR T) (IL:|when| :EXPR T) (IL:|unless| :EXPR T) (IL:|first| (INITIALLY) FILTER-DO) (IL:|finally| FILTER-DO) (IL:|join| (NCONC) FILTER-DO) (IL:|sum| :EXPR T) (IL:|count| :EXPR T) (IL:|always| :EXPR T) (IL:|never| :EXPR T) (IL:|thereis| :EXPR T) (IL:|largest| (MAXIMIZE) :EXPR T) (IL:|smallest| (MINIMIZE) :EXPR T) (IL:|do| FILTER-DO)))) + +(DEFUN CONVERT-ITERATION-STATEMENT (INITIAL-OPER REST-OF-FORM &AUX (REST REST-OF-FORM) (INITIAL INITIAL-OPER) SO-FAR) (IL:* IL:|;;| "Yeah, this is sort of ugly. So is CLISPIFY.") (LABELS ((LOSE (FMT-STRING &REST FMT-ARGS) (WARN "Couldn't translate I.S. form because ~?" FMT-STRING FMT-ARGS) (LET ((FORM (CONS INITIAL-OPER REST-OF-FORM))) (RETURN-FROM CONVERT-ITERATION-STATEMENT FORM))) (NEXT-STATE (KEY CURRENT-LEVEL) (LET* (CLISPWORD (KEY-IS-IS-OPER-P (AND (SYMBOLP KEY) (EQ (CAR (SETQ CLISPWORD (GET KEY (QUOTE IL:CLISPWORD)))) (QUOTE IL:FORWORD)))) (ASSOC-KEY (IF KEY-IS-IS-OPER-P (CDR CLISPWORD) KEY)) (FOUND (OR (ASSOC ASSOC-KEY CURRENT-LEVEL :TEST (FUNCTION (LAMBDA (A B) (IF (AND (SYMBOLP A) (SYMBOLP B)) (STRING-EQUAL A B) (EQ A B))))) (AND (NOT KEY-IS-IS-OPER-P) (OR (ASSOC (QUOTE :EXPR) CURRENT-LEVEL) (ASSOC (QUOTE :EXPR-OR-ASSIGNMENT) CURRENT-LEVEL))) (ASSOC (QUOTE T) CURRENT-LEVEL))) (CURRENT-ENTRY (CDR FOUND))) (IF CURRENT-ENTRY (COND ((AND (EQ (CAR FOUND) :EXPR-OR-ASSIGNMENT) (CONSP KEY) (EQ (SECOND KEY) (QUOTE IL:_))) (SETQ SO-FAR (LIST* (CONVERT (THIRD KEY)) (MAKE-FAKE-SYMBOL "=") (CONVERT (FIRST KEY)) SO-FAR))) ((MEMBER (CAR FOUND) (QUOTE (T :EXPR :EXPR-OR-ASSIGNMENT))) (PUSH (IF (EQ CURRENT-ENTRY (QUOTE T)) NIL (CONVERT KEY)) SO-FAR)) (T (PUSH (MAKE-FAKE-SYMBOL (STRING-UPCASE (STRING KEY))) SO-FAR))) (LOSE "Key ~a not expected" KEY)) (LOOP (COND ((EQ CURRENT-ENTRY (QUOTE T)) (IL:* IL:\; "(mumble . T)") (PUSH KEY REST) (IL:* IL:\; "means punt this token.") (POP SO-FAR) (RETURN-FROM NEXT-STATE)) ((EQ (CAR CURRENT-ENTRY) (QUOTE T)) (RETURN-FROM NEXT-STATE)) ((CONSP (CAR CURRENT-ENTRY)) (IF (CONSP (CAAR CURRENT-ENTRY)) (IL:* IL:|;;| "Assoc list...") (LET ((NEXT-KEY (POP REST))) (NEXT-STATE NEXT-KEY (CAR CURRENT-ENTRY)) (RETURN-FROM NEXT-STATE)) (IL:* IL:|;;| "substitution...") (SETF (CAR SO-FAR) (MAKE-FAKE-SYMBOL (CAAR CURRENT-ENTRY))))) ((MEMBER (CAR CURRENT-ENTRY) (QUOTE (:EXPR-OR-ASSIGNMENT :EXPR))) (IF (AND (SYMBOLP (CAR REST)) (EQ (CAR (GET (CAR REST) (QUOTE IL:CLISPWORD))) (QUOTE IL:FORWORD))) (LOSE "~a where expression expected" (CAR REST)) (PUSH (CONVERT (COPY-TREE (POP REST))) SO-FAR))) ((NULL (CDR CURRENT-ENTRY)) (MULTIPLE-VALUE-SETQ (SO-FAR REST) (FUNCALL (CAR CURRENT-ENTRY) SO-FAR REST (FUNCTION LOSE))) (RETURN-FROM NEXT-STATE)) (T (IF (EQ (CAR CURRENT-ENTRY) (CAR REST)) (PUSH (CONVERT (COPY-TREE (POP REST))) SO-FAR) (LOSE "Expected ~a" (CAR CURRENT-ENTRY))))) (POP CURRENT-ENTRY))))) (LOOP (NEXT-STATE INITIAL *ITERATION-CONVERSION-TABLE*) (WHEN (NULL REST) (RETURN (CONS (MAKE-FAKE-SYMBOL (QUOTE LOOP)) (NREVERSE SO-FAR)))) (SETQ INITIAL (POP REST))))) + +(DEFUN FILTER-NUMERIC-BY (SO-FAR REST)) + +(DEFUN FILTER-LIST-BY (SO-FAR REST) (LET ((STEP-FORM (POP REST)) (VAR (FOURTH SO-FAR)) (OPERAND (SECOND SO-FAR))) (IF (AND (CONSP STEP-FORM) (= (LENGTH STEP-FORM) 2) (OR (EQ (SECOND STEP-FORM) VAR) (IL:* IL:\; "") (EQ (SECOND STEP-FORM) OPERAND))) (PUSH (IL:BQUOTE (QUOTE (IL:\\\, (FIRST STEP-FORM)))) SO-FAR) (LET ((LAMBDA-VAR (MAKE-FAKE-SYMBOL ".X."))) (PUSH (IL:BQUOTE (FUNCTION (LAMBDA ((IL:\\\, LAMBDA-VAR)) (IL:\\\, (SUBLIS (LIST (CONS VAR LAMBDA-VAR) (CONS OPERAND LAMBDA-VAR)) STEP-FORM))))) SO-FAR)))) (VALUES SO-FAR REST)) + +(DEFUN FILTER-BIND (SO-FAR REST LOSE-CONTINUATION &AUX TOKEN (FIRST T)) (IL:* IL:|;;| "Change BIND to WITH.") (SETQ SO-FAR (CONS (MAKE-FAKE-SYMBOL "WITH") (CDR SO-FAR))) (LOOP (WHEN (NULL REST) (RETURN SO-FAR)) (COND ((EQ (SETQ TOKEN (CAR REST)) (QUOTE IL:OLD)) (FUNCALL LOSE-CONTINUATION "OLD not convertable")) ((CONSP TOKEN) (UNLESS FIRST (PUSH (MAKE-FAKE-SYMBOL "AND") SO-FAR)) (POP REST) (PUSH (CONVERT (CAR TOKEN)) SO-FAR) (WHEN (EQ (SECOND TOKEN) (QUOTE IL:_)) (SETF SO-FAR (LIST* (CONVERT (THIRD TOKEN)) (MAKE-FAKE-SYMBOL "=") SO-FAR)))) ((NOT (SYMBOLP TOKEN)) (FUNCALL LOSE-CONTINUATION "Unknown BIND token ~a" TOKEN)) ((EQ (CAR (GET TOKEN (QUOTE IL:CLISPWORD))) (QUOTE IL:FORWORD)) (RETURN (VALUES SO-FAR REST))) (T (UNLESS FIRST (PUSH (MAKE-FAKE-SYMBOL "AND") SO-FAR)) (PUSH (CONVERT TOKEN) SO-FAR) (POP REST) (WHEN (EQ (CAR REST) (QUOTE IL:_)) (SETF SO-FAR (LIST* (CONVERT (CADR REST)) (MAKE-FAKE-SYMBOL "=") SO-FAR) REST (CDDR REST))))) (SETQ FIRST NIL))) + +(DEFUN FILTER-DO (SO-FAR REST IGNORE &AUX TEM) (DECLARE (IGNORE IGNORE)) (LOOP (WHEN (OR (NULL REST) (AND (SYMBOLP (SETQ TEM (CAR REST))) (EQ (CAR (GET TEM (QUOTE IL:CLISPWORD))) (QUOTE IL:FORWORD)))) (RETURN (VALUES SO-FAR REST))) (PUSH (CONVERT (COPY-TREE TEM)) SO-FAR) (POP REST))) + +(DEFUN FILTER-INSTRING (SO-FAR REST IGNORE) (DECLARE (IGNORE IGNORE)) (VALUES (REVAPPEND (IL:BQUOTE ((IL:\\\, (MAKE-FAKE-SYMBOL "BEING")) (IL:\\\, (MAKE-FAKE-SYMBOL "THE")) (IL:\\\, (MAKE-FAKE-SYMBOL "CHARACTERS")) (IL:\\\, (MAKE-FAKE-SYMBOL "OF")) (IL:\\\, (POP REST)))) (CDR SO-FAR)) REST)) + +(DEFUN FILTER-REPEATWHILE/UNTIL (SO-FAR REST IGNORE) (DECLARE (IGNORE IGNORE)) (LET* ((KEY (STRING (FAKE-SYMBOL-NAME (POP SO-FAR)))) (VALUE (COND ((STRING= KEY "REPEATWHILE") (IL:BQUOTE (DO (UNLESS (IL:\\\, (CONVERT (POP REST))) ((IL:\\\, (MAKE-FAKE-SYMBOL "LOOP-FINISH"))))))) ((STRING= KEY "REPEATUNTIL") (IL:BQUOTE (DO (WHEN (IL:\\\, (CONVERT (POP REST))) ((IL:\\\, (MAKE-FAKE-SYMBOL "LOOP-FINISH"))))))) (T (IL:BQUOTE (DO (IL:\\\, (CONVERT (POP REST))))))))) (UNLESS (OR (NULL REST) (EQ (CAR REST) (QUOTE IL:|finally|))) (LET ((*CURRENT-EXPRESSION* (SECOND VALUE))) (WARN "I.S. oper repeatuntil may need to be moved."))) (VALUES (REVAPPEND VALUE SO-FAR) REST))) + + + +(IL:* IL:\| "chapter 10") + + + + +(IL:* IL:|;;| +"These variables can be set to T to make lambdas come out with &REST IGNORE (equiv.) and &OPTIONAL in their parm. lists." +) + + +(DEFVAR *ADD-REST-ARG* NIL) + +(DEFVAR *PARAMETERS-ALWAYS-OPTIONAL* NIL) + +(DEFUN DEFINEQ1 (DEFINEQ-FORM &AUX (NAME (EXTERN (SYMBOL-NAME (FIRST DEFINEQ-FORM)) *IL-PACKAGE*)) (DEFN (SECOND DEFINEQ-FORM)) (FORMS (CDDR DEFINEQ-FORM)) VARLST) (DECLARE (SPECIAL *LOCALS* *CURRENT-FUNCTION-CALLS* *FUNCTION-CALLS*)) (WHEN FORMS (SETQ DEFN (IL:BQUOTE (LAMBDA (IL:\\\, DEFN) (IL:\\\,@ FORMS))))) (SETQ VARLST (SECOND DEFN)) (SETQ *CURRENT-FUNCTION-CALLS* (LIST NAME)) (PROG1 (CASE (FIRST DEFN) (LAMBDA (IF (LISTP VARLST) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST) (LET ((*LOCALS* (APPEND VARNAMES *LOCALS*))) (WHEN NEW-VARLST (PUSH (QUOTE &OPTIONAL) NEW-VARLST)) (IL:BQUOTE (DEFUN (IL:\\\, NAME) ((IL:\\\,@ NEW-VARLST) (IL:\\\,@ (AND *ADD-REST-ARG* (QUOTE (&REST $EXTRA-ARGS$))))) (IL:\\\,@ (AND *ADD-REST-ARG* (QUOTE ((DECLARE (IGNORE $EXTRA-ARGS$)))))) (IL:\\\,@ (MAPCONVERT (CDDR DEFN))))))) (LET ((*LOCALS* (ACONS VARLST :LOCAL *LOCALS*))) (IL:BQUOTE (DEFUN (IL:\\\, NAME) (&REST $ARGS$ &AUX ((IL:\\\, VARLST) (LENGTH $ARGS$))) (IL:\\\,@ (MAPCONVERT (CDDR DEFN)))))))) (NLAMBDA (IF (LISTP VARLST) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST :TYPE :MACRO-ARG) (LET ((*LOCALS* (APPEND VARNAMES *LOCALS*))) (WHEN NEW-VARLST (PUSH (QUOTE &OPTIONAL) NEW-VARLST)) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) ((IL:\\\,@ NEW-VARLST) &REST $EXTRA-ARGS$) (DECLARE (IGNORE $EXTRA-ARGS$)) (IL:\\\, (MAKE-BQ (PROGN-IF-NEEDED (MAPCONVERT (CDDR DEFN))))))))) (LET ((*LOCALS* (ACONS VARLST :MACRO-ARG *LOCALS*))) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) (&REST (IL:\\\, VARLST)) (IL:\\\, (MAKE-BQ (PROGN-IF-NEEDED (MAPCONVERT (CDDR DEFN)))))))))) (T (ERROR "Unknown DEFINEQ type ~a" (FIRST DEFN)))) (PUSH (REVERSE *CURRENT-FUNCTION-CALLS*) *FUNCTION-CALLS*) (SETQ *CURRENT-FUNCTION-CALLS* NIL))) + +(IL-DEFCONV ARG (VAR M) (DECLARE (IGNORE VAR)) (IL:BQUOTE (NTH (IL:\\\, (SIMP-1- (CONVERT M))) $ARGS$))) + +(IL-DEFCONV SETARG (VAR M X) (DECLARE (IGNORE VAR)) (IL:BQUOTE (SETF (NTH (1- (IL:\\\, (CONVERT M))) $ARGS$) (IL:\\\, (CONVERT X))))) + +(IL-DEFCONV DEFINEQ (&REST ARGS) (PROGN-IF-NEEDED (MAPCAR (QUOTE DEFINEQ1) ARGS))) + + + +(IL:* IL:|;;| +"(convert '(defineq (foo (lambda (a b) (plus a b c))))) (convert '(defineq (foo (nlambda (a b) (plus a b c))))) (convert '(defineq (foo (lambda x (plus (arg x 1) (arg x 2)))))) (convert '(defineq (foo (nlambda x (mapcar 'foo x))))) ***** FNTYP, EXPRP, CCODEP, ARGTYPE, NARGS, ARGLIST, SMARTARGLIST ***** DEFINE ***** UNSAVE.TO.MODIFY.FNS, DFNFLG" +) + + +(IL-DEFCONV PUTD (FN &OPTIONAL DEF &REST EXTRA) (DECLARE (IGNORE EXTRA)) (IL:BQUOTE (IF (NULL (IL:\\\, (CONVERT DEF))) (MAKUNBOUND (IL:\\\, (CONVERT FN))) (SETF (SYMBOL-FUNCTION (IL:\\\, (CONVERT FN))) (IL:\\\, (CONVERT DEF)))))) + +(IL-DEFCONV CCODEP (SYM) (LET ((S (MAKE-FAKE-SYMBOL ".X."))) (IL:BQUOTE (LET (((IL:\\\, S) (IL:\\\, (CONVERT SYM)))) "CCODEP" (AND (FBOUNDP (IL:\\\, S)) (COMPILED-FUNCTION-P (SYMBOL-FUNCTION (IL:\\\, S)))))))) + +(IL-COPYDEF SYMBOL-FUNCTION GETD) + +(IL-COPYDEF APPLY) + +(IL-COPYDEF FUNCALL APPLY*) + +(IL-DEFCONV KWOTE (FORM) (IF (IL:CONSTANTEXPRESSIONP FORM) (CONVERT FORM) (IL:BQUOTE (LIST (QUOTE QUOTE) (IL:\\\, (CONVERT FORM)))))) + + + +(IL:* IL:|;;| +"(il-defconv QUOTE (&rest args) `(quote ,@args)) ***** NLAMBDA.ARGS,^ EVALA,^ DEFEVAL,^ EVALHOOK") + + + + +(IL:* IL:|;;| +" +; is this right? +(il-defconv RPTQ (n &rest forms) + `(do ((IL::RPTN ,^(eval n) (1- IL::RPTN)) + val) + ((<= IL::RPTN 0) val) + (declare (special IL::RPTN)) + (setq val (progn ,@^@forms)))) +") + + + + +(IL:* IL:\; "***** RPTQ, FRPTQ") + + +(IL-DEFCONV MOVD (FROM TO &OPTIONAL COPYFLG DONTCOPY) (SETQ *CURRENT-EXPRESSION* (IL:BQUOTE (SETF (SYMBOL-FUNCTION (IL:\\\, (CONVERT TO))) (SYMBOL-FUNCTION (IL:\\\, (CONVERT FROM)))))) (WHEN (OR COPYFLG DONTCOPY) (WARN "MOVD can't translate argument copyflg or dontcopy")) *CURRENT-EXPRESSION*) + +(IL-DEFCONV MAP (MAPX MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAP does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPL (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, (CONVERT MAPX))))) + +(IL-DEFCONV MAPC (MAPX MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAPC does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPC (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, (CONVERT MAPX))))) + +(IL-DEFCONV MAPLIST (MAPX MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAPLIST does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPLIST (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, (CONVERT MAPX))))) + +(IL-DEFCONV MAPCAR (MAPX MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAPCAR does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPCAR (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, (CONVERT MAPX))))) + +(IL-DEFCONV MAPCON (MAPX MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAPCON does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPCON (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, (CONVERT MAPX))))) + +(IL-DEFCONV MAPCONC (MAPX MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAPCONC does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPCAN (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, (CONVERT MAPX))))) + +(IL-DEFCONV MAP2C (MAPX MAPY MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAP2C does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPC (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, (CONVERT MAPX)) (IL:\\\, (CONVERT MAPY))))) + +(IL-DEFCONV MAP2CAR (MAPX MAPY MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAP2CAR does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPCAR (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, (CONVERT MAPX)) (IL:\\\, (CONVERT MAPY))))) + +(IL-DEFCONV SUBSET (MAPX MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "SUBSET does not yet support MAPFN2 arg")) (IL:BQUOTE (REMOVE-IF-NOT (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, (CONVERT MAPX))))) + + + +(IL:* IL:\; "***** rest of chapter") + + +(IL-WARNINGFORM IL:MOVD?) + + + +(IL:* IL:\| "chapter 14") + + +(DEFVAR *WARN-ON-ERSETQ-NLSETQ* T "Warn on these for later rewrite.") + +(IL-DEFCONV SHOULDNT (MESS) (IL:BQUOTE (ERROR "Shouldn't happen: ~a" (IL:\\\, (CONVERT MESS))))) + +(IL-DEFCONV ERROR (&OPTIONAL MESS1 MESS2 NOBREAK) (IL:BQUOTE (ERROR "~a ~a" (IL:\\\, (CONVERT MESS1)) (IL:\\\, (CONVERT MESS2))))) + +(IL-DEFCONV NLSETQ (FORM) (LIST (MAKE-FAKE-SYMBOL "IGNORE-ERRORS") (CONVERT FORM))) + +(IL-DEFCONV ERSETQ (&REST FORMS) (LET ((CVAR (MAKE-FAKE-SYMBOL "C"))) (IL:BQUOTE ((IL:\\\, (MAKE-FAKE-SYMBOL "CONDITION-CASE")) (IL:\\\, (IF (NULL (CDR FORMS)) (CONVERT (FIRST FORMS)) (IL:BQUOTE (PROGN (IL:\\\,. (MAPCONVERT FORMS)))))) (ERROR ((IL:\\\, CVAR)) (PRINC (IL:\\\, CVAR)) (VALUES NIL (IL:\\\, CVAR))))))) + + + +(IL:* IL:\| "chapter 17") + + +(DEFVAR *EVAL-WHEN-STATE* (QUOTE (LOAD EVAL))) + +(IL-DEFCONV DECLARE\: (&REST ARGS) (DO ((FORMS NIL) (EVAL-WHEN-EVAL T) (EVAL-WHEN-COMPILE NIL) (EVAL-WHEN-LOAD T) (FIRST NIL) (TMPFORMS NIL) (FIRSTFORMS NIL) ARG) NIL (WHEN (AND TMPFORMS (OR (ENDP ARGS) (ATOM (FIRST ARGS)))) (LET* ((NEW-EVAL-WHEN-STATE (IL:BQUOTE ((IL:\\\,@ (IF EVAL-WHEN-EVAL (QUOTE (EVAL)))) (IL:\\\,@ (IF EVAL-WHEN-COMPILE (QUOTE (COMPILE)))) (IL:\\\,@ (IF EVAL-WHEN-LOAD (QUOTE (LOAD))))))) (OLD-EVAL-WHEN-STATE *EVAL-WHEN-STATE*) (*EVAL-WHEN-STATE* NEW-EVAL-WHEN-STATE)) (SETQ TMPFORMS (IL:BQUOTE ((IL:\\\, (IF (NULL (SET-DIFFERENCE NEW-EVAL-WHEN-STATE *EVAL-WHEN-STATE*)) (QUOTE PROGN) (QUOTE EVAL-WHEN))) (IL:\\\,@ (MAPCONVERT (REVERSE TMPFORMS))))))) (IF FIRST (PUSH TMPFORMS FIRSTFORMS) (PUSH TMPFORMS FORMS)) (SETQ TMPFORMS NIL)) (WHEN (ENDP ARGS) (RETURN (CONS (QUOTE PROGN) (APPEND (REVERSE FIRSTFORMS) (REVERSE FORMS))))) (SETQ ARG (POP ARGS)) (IF (ATOM ARG) (CASE ARG ((EVAL@LOAD DOEVAL@LOAD) (SETQ EVAL-WHEN-EVAL T)) (DONTEVAL@LOAD (SETQ EVAL-WHEN-EVAL NIL)) (EVAL@LOADWHEN (SETQ EVAL-WHEN-EVAL (EVAL (POP ARGS)))) ((EVAL@COMPILE DOEVAL@COMPILE) (SETQ EVAL-WHEN-COMPILE T)) (DONTEVAL@COMPILE (SETQ EVAL-WHEN-COMPILE NIL)) (EVAL@COMPILEWHEN (SETQ EVAL-WHEN-COMPILE (EVAL (POP ARGS)))) ((COPY DOCOPY) (SETQ EVAL-WHEN-LOAD T)) (DONTCOPY (SETQ EVAL-WHEN-LOAD NIL)) (COPYWHEN (SETQ EVAL-WHEN-LOAD (EVAL (POP ARGS)))) (FIRST (SETQ FIRST T)) (NOTFIRST (SETQ FIRST NIL)) (T (WARN "Unknown option ~a in DECLARE:" ARG))) (PUSH ARG TMPFORMS)))) + +(IL-DEFCONV PUTPROPS (ATM &REST VARS) (DECLARE (SPECIAL *LOCALS*)) (PROGN-IF-NEEDED (DO ((VARS VARS (REST (REST VARS))) (FORMS NIL)) ((ENDP VARS) (REVERSE FORMS)) (PUSH (CASE (FIRST VARS) ((MACRO DMACRO) (DEFINE-MACRO (EXTERN (SYMBOL-NAME ATM) *IL-PACKAGE*) (SECOND VARS))) (T (IL:BQUOTE (SETF (GET (IL:\\\, (CONVERT (IL:BQUOTE (QUOTE (IL:\\\, ATM))))) (IL:\\\, (CONVERT (IL:BQUOTE (QUOTE (IL:\\\, (FIRST VARS))))))) (IL:\\\, (CONVERT (IL:BQUOTE (QUOTE (IL:\\\, (SECOND VARS)))))))))) FORMS)))) + +(DEFUN DEFINE-MACRO (NAME DEFN) (COND ((EQ (CAR DEFN) (QUOTE =)) (IL:BQUOTE (SETF (SYMBOL-FUNCTION (QUOTE (IL:\\\, NAME))) (SYMBOL-FUNCTION (QUOTE (IL:\\\, (EXTERN (CDR DEFN) *IL-PACKAGE*))))))) ((MEMBER (FIRST DEFN) (QUOTE (LAMBDA OPENLAMBDA)) :TEST (FUNCTION EQ)) (DEFINE-SUBST-MACRO NAME (REST DEFN))) (T (DEFINE-SUBST-MACRO NAME DEFN)))) + +(DEFUN DEFINE-SUBST-MACRO (NAME DEFN &AUX VARNAMES FORMS ARGLIST) (SETQ VARNAMES (FIRST DEFN)) (SETQ ARGLIST VARNAMES) (SETQ FORMS (REST DEFN)) (WHEN (AND VARNAMES (ATOM VARNAMES)) (SETQ VARNAMES (LIST VARNAMES))) (LET ((*LOCALS* (APPEND (MAPCAR (FUNCTION (LAMBDA (NAME) (IL:BQUOTE ((IL:\\\, NAME) . :MACRO-ARG)))) (MAKE-TRUE-LIST VARNAMES)) *LOCALS*))) (COND ((AND ARGLIST (ATOM ARGLIST)) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) (&REST (IL:\\\, ARGLIST)) (IL:\\\, (MAKE-BQ (PROGN-IF-NEEDED (MAPCONVERT FORMS))))))) ((TRUE-LIST-P ARGLIST) (WHEN ARGLIST (PUSH (QUOTE &OPTIONAL) ARGLIST)) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) ((IL:\\\,@ ARGLIST) (IL:\\\,@ (AND *ADD-REST-ARG* (QUOTE (&REST $EXTRA-ARGS$))))) (IL:\\\,@ (AND *ADD-REST-ARG* (QUOTE ((DECLARE (IGNORE $EXTRA-ARGS$)))))) (IL:\\\, (MAKE-BQ (PROGN-IF-NEEDED (MAPCONVERT FORMS))))))) (T (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) (IL:\\\, ARGLIST) (IL:\\\, (MAKE-BQ (PROGN-IF-NEEDED (MAPCONVERT FORMS)))))))))) + +(IL-DEFCONV QUOTE (ARG) (IL:BQUOTE (QUOTE (IL:\\\, (QUOTE-TREE ARG))))) + + + +(IL:* IL:|;;| "(il-defconv * (&rest args) `(il::* ,@args))") + + + + +(IL:* IL:|;;| "what are we supposed to do with (declare (specvars . t)) ?") + + +(DEFVAR *TYPE-CONVERSION-PLIST* (QUOTE (IL:SPECVARS SPECIAL IL:GLOBALVARS NIL))) + +(IL-DEFCONV DECLARE (&REST ARGS) (IL:BQUOTE (DECLARE (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (ARG) (LET ((TYPE (GETF *TYPE-CONVERSION-PLIST* (FIRST ARG) :NOT-FOUND))) (WHEN (AND (EQ TYPE :NOT-FOUND) (STRING= (PACKAGE-NAME (SYMBOL-PACKAGE (FIRST ARG))) "INTERLISP")) (WARN "Unknown type in DECLARE ~s" (FIRST ARG)) (SETQ TYPE (FIRST ARG))) (AND TYPE (IL:BQUOTE (((IL:\\\, TYPE) (IL:\\\,@ (IF (CONSP (REST ARG)) (MAPCONVERT (REST ARG)) NIL))))))))) ARGS))))) + +(IL-DEFCONV FILEMAP (&REST ARGS) (DECLARE (IGNORE ARGS)) NIL) + +(IL-DEFCONV ADDTOVAR (VAR &REST ARGS) (IL:BQUOTE (IL:ADDTOVAR (IL:\\\, (CONVERT VAR)) (IL:\\\,@ (QUOTE-TREE ARGS))))) + +(IL-DEFCONV APPENDTOVAR (VAR &REST ARGS) (IL:BQUOTE (IL:APPENDTOVAR (IL:\\\, (CONVERT VAR)) (IL:\\\,@ (QUOTE-TREE ARGS))))) + +(IL-DEFCONV FUNCTION (FN &OPTIONAL ENV) (IL:* IL:|;;| " This should barf on NLAMBDA forms!") (WHEN ENV (WARN "FUNCTION does not support environment")) (COND ((NOT (SYMBOLP FN)) (IL:BQUOTE (FUNCTION (IL:\\\, (CONVERT FN))))) ((GET FN (QUOTE CONVERT-FORM)) (IL:* IL:|;;| "Fake up a way to make it work...") (LET* ((NEW-AL (MAPCAR (FUNCTION (LAMBDA (X) (GENTEMP "G"))) (IL:ARGLIST FN))) (CONVERSION (CONVERT (CONS FN NEW-AL)))) (IF (EQUAL (CDR CONVERSION) NEW-AL) (IL:* IL:|;;| "If it turns into a different fcn with the same args, do it the easy way...") (IL:BQUOTE (FUNCTION (IL:\\\, (CAR CONVERSION)))) (IL:* IL:|;;| "Whole different expression; use full-dress adaptor") (IL:BQUOTE (FUNCTION (LAMBDA (&OPTIONAL (IL:\\\,. NEW-AL)) (IL:\\\, (LIST (QUOTE IL:*) (QUOTE IL:|;;|) (STRING FN))) (IL:\\\, CONVERSION))))))) (T (IL:BQUOTE (FUNCTION (IL:\\\, (NOTE-EXPORTED-SYMBOL FN))))))) + +(IL-DEFCONV LAMBDA (VARLST &REST FORMS) (IF (LISTP VARLST) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST) (LET ((*LOCALS* (APPEND VARNAMES *LOCALS*))) (IL:BQUOTE (LAMBDA (&OPTIONAL (IL:\\\,@ NEW-VARLST)) (IL:\\\,@ (MAPCONVERT FORMS)))))) (LET ((*LOCALS* (ACONS VARLST :LOCAL *LOCALS*))) (IL:BQUOTE (LAMBDA (&REST $ARGS$ &AUX ((IL:\\\, VARLST) (LENGTH $ARGS$))) (IL:\\\,@ (MAPCONVERT FORMS))))))) + +(IL-DEFCONV DEFINE-FILE-INFO (&REST IGNORE) NIL) + +(IL-DEFCONV PRETTYCOMPRINT (&REST IGNORE) NIL) + +(SETF (GET (QUOTE FILECREATED) (QUOTE EARLY)) T) + +(IL-DEFCONV FILECREATED (&REST JUNK) (CONVERT (LIST* (QUOTE *) (QUOTE |;;;|) "File Created " JUNK))) + + + +(IL:* IL:\| "chapter 18") + + +(IL-DEFCONV CONSTANT (X) (LIST (QUOTE QUOTE) (MAKE-SHARP-COMMA :CONTENTS (CONVERT X)))) + + + +(IL:* IL:\| "chapter 23") + + +(IL-COPYDEF PROCESSP) + +(IL-DEFCONV CREATE.MONITORLOCK (NAME &OPTIONAL EXCLUSIVE) (SETQ *CURRENT-EXPRESSION* (IL:BQUOTE ((IL:\\\, (MAKE-FAKE-SYMBOL "UE:MAKE-PROCESS-LOCK")) :NAME (IL:\\\, (CONVERT NAME))))) (WHEN EXCLUSIVE (WARN "CREATE.MONITORLOCK cannot handle arg EXCLUSIVE")) *CURRENT-EXPRESSION*) + +(IL-DEFCONV OBTAIN.MONITORLOCK (LOCK &OPTIONAL DONTWAIT UNWINDSAVE) (LET* ((PROCESS-LOCK-LOCKER (MAKE-FAKE-SYMBOL "UE:PROCESS-LOCK-LOCKER")) (CURRENT-PROCESS (MAKE-FAKE-SYMBOL "UE:CURRENT-PROCESS")) (PROCESS-LOCK (MAKE-FAKE-SYMBOL "UE:PROCESS-LOCK")) (WITHOUT-SCHEDULING (MAKE-FAKE-SYMBOL "UE:WITHOUT-SCHEDULING")) (LVAR (MAKE-FAKE-SYMBOL (QUOTE ..L..))) (OVAR (MAKE-FAKE-SYMBOL (QUOTE ..OWNER..))) (BODY (IL:BQUOTE (LET* (((IL:\\\, LVAR) (IL:\\\, (CONVERT LOCK))) ((IL:\\\, OVAR) ((IL:\\\, PROCESS-LOCK-LOCKER) (IL:\\\, LVAR)))) "OBTAIN.MONITORLOCK" (COND ((EQ (IL:\\\, OVAR) ((IL:\\\, CURRENT-PROCESS))) T) ((NULL (IL:\\\, OVAR)) (IF (IL:\\\, (CONVERT DONTWAIT)) ((IL:\\\, WITHOUT-SCHEDULING) (WHEN (NULL ((IL:\\\, PROCESS-LOCK-LOCKER) (IL:\\\, LVAR))) ((IL:\\\, PROCESS-LOCK) (IL:\\\, LVAR)) (IL:\\\, LVAR))) (PROGN ((IL:\\\, PROCESS-LOCK) (IL:\\\, LVAR)) (IL:\\\, LVAR)))) (T (WHEN (NULL (IL:\\\, DONTWAIT)) ((IL:\\\, PROCESS-LOCK) (IL:\\\, LVAR)) (IL:\\\, LVAR)))))))) (IF UNWINDSAVE (IL:BQUOTE (UNWIND-PROTECT (IL:\\\, BODY) (IL:\\\, (CONVERT UNWINDSAVE)))) BODY))) + +(IL-DEFCONV RELEASE.MONITORLOCK (LOCK &OPTIONAL EVENIFNOTMINE) (IL:BQUOTE ((IL:\\\, (MAKE-FAKE-SYMBOL "UE:PROCESS-UNLOCK")) (IL:\\\, (CONVERT LOCK)) ((IL:\\\, (MAKE-FAKE-SYMBOL "UE:CURRENT-PROCESS"))) T))) + +(IL-DEFCONV WITH.MONITOR (LOCK &REST BODY) (IL:BQUOTE ((IL:\\\, (MAKE-FAKE-SYMBOL "UE:WITH-PROCESS-LOCK")) (IL:\\\, (CONVERT LOCK)) (IL:\\\,. (MAPCONVERT BODY))))) + +(IL-DEFCONV NOTIFY.EVENT (EVENT &OPTIONAL ONCEONLY) (SETQ *CURRENT-EXPRESSION* (IL:BQUOTE ((IL:\\\, (MAKE-FAKE-SYMBOL "UE:PROCESS-UNLOCK")) (IL:\\\, (CONVERT EVENT))))) (WHEN ONCEONLY (WARN "NOTIFY.EVENT cannot handle arg ONCEONLY")) *CURRENT-EXPRESSION*) + +(IL-DEFCONV THIS.PROCESS (&REST ARGS) (CONS (MAKE-FAKE-SYMBOL "UE:CURRENT-PROCESS") (MAPCONVERT ARGS))) + +(IL-WARNINGFORM IL:AWAIT.EVENT) + +(IL-WARNINGFORM IL:CREATE.EVENT) + + + +(IL:* IL:\| "chapter 24") + + +(IL-DEFCONV OPENSTRINGSTREAM (STR &OPTIONAL ACCESS) (COND ((OR (NULL ACCESS) (EQUAL ACCESS (QUOTE (QUOTE IL:INPUT)))) (IL:BQUOTE (MAKE-STRING-INPUT-STREAM (IL:\\\, (CONVERT STR))))) ((EQUAL ACCESS (QUOTE (QUOTE IL:OUTPUT))) (LET ((BODY (LIST (QUOTE MAKE-STRING-OUTPUT-STREAM)))) (WHEN STR (LET ((*CURRENT-EXPRESSION* BODY)) (WARN "STRING arg to OPENSTRINGSTREAM not translated; use GET-OUTPUT-STREAM-STRING in the appropriate place"))) BODY)) ((EQUAL ACCESS (QUOTE (QUOTE IL:BOTH))) (WARN "Can't translate OPENSTRINGSTREAM for BOTH.") *CURRENT-EXPRESSION*) (T (WARN "Can't translate OPENSTRINGSTREAM for variable access type.") *CURRENT-EXPRESSION*))) + + + +(IL:* IL:\| "chapter 25") + + +(IL-COPYDEF PRINT) + +(IL-COPYDEF TERPRI) + +(IL-COPYDEF PRIN1 PRIN2) + +(IL-COPYDEF PRINC PRIN1) + +(IL-COPYDEF READ-CHAR BIN) + +(IL-COPYDEF WRITE-CHAR BOUT) + +(DEFVAR *ANNOTATE-PRINTOUT-FORM* NIL "Include the original printout form as an annotation.") + +(IL-DEFCONV PRINTOUT (STREAM &REST ARGS &AUX SUBSTRINGS FMTARGS FORMS (ARGSTAIL ARGS) ARG) (LOOP (WHEN (NULL ARGSTAIL) (RETURN)) (SETF ARG (POP ARGSTAIL)) (TYPECASE ARG (STRING (PUSH ARG SUBSTRINGS)) (INTEGER (PUSH (FORMAT NIL "~~~d~:[~;@~]T" (ABS ARG) (MINUSP ARG)) SUBSTRINGS)) (SYMBOL (LABELS ((MAYBE-NUMERIC-ARG (ARG FORMAT) (PUSH "~" SUBSTRINGS) (IF (INTEGERP ARG) (PUSH (WRITE-TO-STRING ARG :BASE 10) SUBSTRINGS) (PROGN (PUSH "V" SUBSTRINGS) (PUSH (CONVERT ARG) FMTARGS))) (PUSH FORMAT SUBSTRINGS)) (ESCAPE-FORM (FORM) (PUSH (IL:BQUOTE (FORMAT (IL:\\\, (OR STREAM T)) (IL:\\\, (APPLY (FUNCTION CONCATENATE) (QUOTE STRING) (NREVERSE SUBSTRINGS))) (IL:\\\,@ (NREVERSE FMTARGS)))) FORMS) (PUSH FORM FORMS) (SETQ SUBSTRINGS NIL FMTARGS NIL))) (CASE ARG ((T) (PUSH "~%" SUBSTRINGS)) ((IL:\, IL:|,,| IL:|,,,|) (PUSH (MAKE-STRING (LENGTH (STRING ARG)) :INITIAL-ELEMENT #\Space) SUBSTRINGS)) (IL:.SP (MAYBE-NUMERIC-ARG (POP ARGSTAIL) "@T")) (IL:.TAB (MAYBE-NUMERIC-ARG (POP ARGSTAIL) "T")) (IL:.TAB0 (WARN "PRINTOUT command .TAB0 treated like .TAB") (MAYBE-NUMERIC-ARG (POP ARGSTAIL) "T")) (IL:.SKIP (MAYBE-NUMERIC-ARG (POP ARGSTAIL) "%")) (IL:.PAGE (PUSH "~|" SUBSTRINGS)) (IL:|.P2| (PUSH "~s" SUBSTRINGS) (PUSH (CONVERT (POP ARGSTAIL)) FMTARGS)) ((IL:.PPV IL:PPF) (ESCAPE-FORM (IL:BQUOTE (PPRINT (IL:\\\, (CONVERT (POP ARGSTAIL))) (IL:\\\, (CONVERT (OR STREAM T))))))) ((IL:.PPVTL IL:.PPFTL) (ESCAPE-FORM (IL:BQUOTE (DO ((.X. (IL:\\\, (CONVERT (POP ARGSTAIL))) (CDR .X.))) (NIL) (PPRINT (CAR .X.) (IL:\\\, (CONVERT (OR STREAM T)))) (UNLESS (CDR .X.) (RETURN)) (WRITE-CHAR #\Space (OR STREAM T)))))) (IL:\# (ESCAPE-FORM (POP ARGSTAIL))) (OTHERWISE (LET ((SA (SYMBOL-NAME ARG))) (IF (CHAR= (CHAR SA 0) #\.) (WARN "Couldn't translate PRINTOUT command ~a." ARG) (PROGN (PUSH "~a" SUBSTRINGS) (PUSH (CONVERT ARG) FMTARGS)))))))) (T (PUSH "~a" SUBSTRINGS) (PUSH (CONVERT ARG) FMTARGS)))) (WHEN SUBSTRINGS (PUSH (IL:BQUOTE (FORMAT (IL:\\\, (OR STREAM T)) (IL:\\\, (APPLY (FUNCTION CONCATENATE) (QUOTE STRING) (NREVERSE SUBSTRINGS))) (IL:\\\,@ (NREVERSE FMTARGS)))) FORMS)) (IF (OR *ANNOTATE-PRINTOUT-FORM* (> (LENGTH FORMS) 1)) (IL:BQUOTE (PROGN (IL:\\\, (LIST (QUOTE IL:*) (QUOTE IL:|;;|) (LET ((*PACKAGE* (FIND-PACKAGE (QUOTE IL)))) (WRITE-TO-STRING (LIST* (QUOTE IL:PRINTOUT) STREAM ARGS))))) (IL:\\\,@ (NREVERSE FORMS)))) (FIRST FORMS))) + +(IL-DEFCONV READ (STREAM &OPTIONAL RDTBL FLG) (DECLARE (IGNORE FLG)) (IF RDTBL (IL:BQUOTE (LET ((*READTABLE* (IL:\\\, (CONVERT RDTBL)))) (READ (IL:\\\, (CONVERT STREAM))))) (IL:BQUOTE (READ (IL:\\\, (CONVERT STREAM)))))) + +(IL-DEFCONV READP (FILE &OPTIONAL FLG) (DECLARE (IGNORE FLG)) (IL:BQUOTE (LISTEN (IL:\\\, (CONVERT FILE))))) + +(IL-COPYCONV PRINTOUT |printout|) + + + +(IL:* IL:|;;| "Warning forms") + + +(IL-WARNINGFORM IL:INPUT) + +(IL-WARNINGFORM IL:RATOM) + +(IL-WARNINGFORM IL:RSTRING) + +(IL-WARNINGFORM IL:RATOMS) + +(IL-WARNINGFORM IL:RATEST) + +(IL-WARNINGFORM IL:READC) + +(IL-WARNINGFORM IL:PEEKC) + +(IL-WARNINGFORM IL:LASTC) + +(IL-WARNINGFORM IL:READCCODE) + +(IL-WARNINGFORM IL:PEEKCCODE) + +(IL-WARNINGFORM IL:READP) + +(IL-WARNINGFORM IL:EOFP) + +(IL-WARNINGFORM IL:WAITFORINPUT) + +(IL-WARNINGFORM IL:SKREAD) + +(IL-WARNINGFORM IL:SKIPSEPRS) + +(IL-WARNINGFORM IL:OUTPUT) + +(IL-WARNINGFORM IL:PRIN3) + +(IL-WARNINGFORM IL:PRIN4) + +(IL-WARNINGFORM IL:PRINTCCODE) + +(IL-WARNINGFORM IL:TAB) + +(IL-WARNINGFORM IL:SHOWPRIN2) + +(IL-WARNINGFORM IL:SHOWPRINT) + +(IL-WARNINGFORM IL:PRINTBELLS) + +(IL-WARNINGFORM IL:LINELENGTH) + +(IL-WARNINGFORM IL:SETLINELENGTH) + + + +(IL:* IL:\| "Unconvertable things...") + + + + +(IL:* IL:|;;| "Warning forms") + + +(IL-WARNINGFORM IL:WINDOWADDPROP) + +(IL-WARNINGFORM IL:\\PUTBASE) + +(IL-WARNINGFORM IL:\\GETBASE) + +(IL-WARNINGFORM IL:DSPLEFTMARGIN) + +(IL-WARNINGFORM IL:RESETLST) + +(IL-WARNINGFORM IL:WINDOWPROP) + +(IL-WARNINGFORM IL:SMARTARGLIST) + +(IL-WARNINGFORM IL:EDITGETD) + +(IL-WARNINGFORM IL:FIND.PROCESS) + +(IL-WARNINGFORM IL:PROCESS.EVALV) + +(IL-WARNINGFORM IL:PROCESSP) + +(IL-WARNINGFORM IL:PROCESS.EVAL) + +(IL-WARNINGFORM IL:FREEMENU) + +(IL-WARNINGFORM IL:FM.RESETMENU) + +(IL-WARNINGFORM IL:FM.CHANGESTATE) + +(IL-WARNINGFORM IL:FM.CHANGELABEL) + +(IL-WARNINGFORM IL:FM.ITEMPROP) + +(IL-WARNINGFORM IL:FM.EDITITEM) + +(IL-WARNINGFORM IL:FM.GETITEM) + +(IL-WARNINGFORM IL:MAINWINDOW) + +(IL-WARNINGFORM IL:RESETFORM) + +(IL-WARNINGFORM IL:SETTERMTABLE) + +(IL-WARNINGFORM IL:PROCESSPROP) + +(IL-WARNINGFORM IL:TTY.PROCESS) + +(IL-WARNINGFORM IL:CLEARW) + +(IL-WARNINGFORM IL:\\CARET.DOWN) + +(IL-WARNINGFORM IL:\\SMASHSTRING) + +(IL-WARNINGFORM IL:BKSYSBUF) + +(IL-WARNINGFORM IL:CLEARBUF) + +(IL-WARNINGFORM IL:GETSYNTAX) + +(IL-WARNINGFORM IL:OPENWP) + +(IL-WARNINGFORM IL:STRINGWIDTH) + +(IL-WARNINGFORM IL:CHARWIDTH) + +(IL-WARNINGFORM IL:FLASHWINDOW) + +(IL-WARNINGFORM IL:MENU) + +(IL-WARNINGFORM IL:FONTCREATE) + +(IL-WARNINGFORM IL:TTYINPROMPTFORWORD) + +(IL-WARNINGFORM IL:MOUSECONFIRM) + +(IL-WARNINGFORM IL:CLOSEW) + +(IL-WARNINGFORM IL:ATTACHWINDOW) + +(IL-WARNINGFORM IL:SHAPEW) + +(IL-WARNINGFORM IL:CONCATLIST) + +(IL-WARNINGFORM IL:GETPROMPTWINDOW) + +(IL-WARNINGFORM IL:BITBLT) + +(IL-WARNINGFORM IL:BLTSHADE) + +(IL-WARNINGFORM IL:BITMAPWIDTH) + +(IL-WARNINGFORM IL:BITMAPHEIGHT) + +(IL-WARNINGFORM IL:FONTPROP) + +(IL-WARNINGFORM IL:TEDIT.INSERT) + +(IL-WARNINGFORM IL:TEDIT.PARALOOKS) + +(IL-WARNINGFORM IL:DSPCLIPPINGREGION) + +(IL-WARNINGFORM IL:MOVETO) + +(IL-WARNINGFORM IL:RELMOVETO) + +(IL-WARNINGFORM IL:DSPFONT) + +(IL-WARNINGFORM IL:DSPXPOSITION) + +(IL-WARNINGFORM IL:CURSORCREATE) + +(IL-WARNINGFORM IL:WAIT.FOR.TTY) + +(IL-WARNINGFORM IL:\\SAVEVMEMBACKGROUND) + +(IL-WARNINGFORM IL:GETREGION) + +(IL-WARNINGFORM IL:WINDOWREGION) + +(IL-WARNINGFORM IL:EVALV) + +(IL-WARNINGFORM IL:TTY/EDITE) + +(IL-WARNINGFORM IL:CLISPTRAN) + +(IL-WARNINGFORM IL:TTY/EDITL) + +(IL-WARNINGFORM IL:MARKASCHANGED) + +(IL-WARNINGFORM IL:FIXEDITDATE) + +(IL-WARNINGFORM IL:PUTDEF) + +(IL-WARNINGFORM IL:ADDSPELL) + +(IL-WARNINGFORM IL:PROCESS.APPLY) + +(IL-WARNINGFORM IL:STKPOS) + +(IL-WARNINGFORM IL:EDITMODE) + +(IL-WARNINGFORM IL:TOTOPW) + +(IL-WARNINGFORM IL:EXPANDW) + +(IL-WARNINGFORM IL:ADD.PROCESS) + +(IL-WARNINGFORM IL:INSIDEP) + +(IL-WARNINGFORM IL:LASTMOUSEX) + +(IL-WARNINGFORM IL:LASTMOUSEY) + +(IL-WARNINGFORM IL:CREATEW) + +(IL-WARNINGFORM IL:DSPLINEFEED) + +(IL-WARNINGFORM IL:DSPRIGHTMARGIN) + +(IL-WARNINGFORM IL:DOWINDOWCOM) + +(IL-WARNINGFORM IL:TTY.PROCESSP) + +(IL-WARNINGFORM IL:IN/SCROLL/BAR?) + +(IL-WARNINGFORM IL:SCROLL.HANDLER) + +(IL-WARNINGFORM IL:BLOCK) + +(IL-WARNINGFORM IL:CLOCK) + +(IL-WARNINGFORM IL:DSPXOFFSET) + +(IL-WARNINGFORM IL:DSPYOFFSET) + +(IL-WARNINGFORM IL:CREATEREGION) + +(IL-WARNINGFORM IL:HEIGHTIFWINDOW) + +(IL-WARNINGFORM IL:SCROLLW) + +(IL-WARNINGFORM IL:WXOFFSET) + +(IL-WARNINGFORM IL:WYOFFSET) + +(IL-WARNINGFORM IL:KEYDOWNP) + +(IL-WARNINGFORM IL:SHIFTDOWNP) + +(IL-WARNINGFORM IL:UNTILMOUSESTATE) + +(IL-WARNINGFORM IL:FIND-READTABLE) + +(IL-WARNINGFORM IL:NILL) + +(IL-WARNINGFORM IL:FILECOMS) + +(IL-WARNINGFORM IL:ADDFILE) + +(IL-WARNINGFORM IL:ADDTOFILE) + +(IL-WARNINGFORM IL:READTABLEPROP) + +(IL-WARNINGFORM IL:LINELENGTH) + +(IL-WARNINGFORM IL:GETDEF) + + + +(IL:* IL:\| "Filecom converters") + + +(DEFUN CONVERT-FNS (FNS) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (QUOTE CONVERT-ONE-FN) FNS))) + +(DEFUN CONVERT-ONE-FN (FN) (COND ((SYMBOLP FN)) ((AND (CONSP FN) (EQ (CAR FN) (QUOTE IL:*))) (RETURN-FROM CONVERT-ONE-FN NIL)) (T (WARN "Unconvertable FNS element: ~s" FN) (RETURN-FROM CONVERT-ONE-FN NIL))) (LET* ((DEFN (IL:VIRGINFN FN)) (NAME FN) (VARLST (SECOND DEFN)) (*CURRENT-DEFINITION* NAME) (*CURRENT-DEFINITION-TYPE* "Function") (*CURRENT-FUNCTION-CALLS* (LIST NAME)) (*CURRENT-FREE-REFERENCES* (LIST NAME)) (CONVERSION (CASE (FIRST DEFN) ((LAMBDA IL:LAMBDA) (IL:* IL:|;;| "cl:lambda may actually want its own clause...") (IF (LISTP VARLST) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST) (LET ((*LOCALS* (COPY-LIST VARNAMES))) (WHEN (AND NEW-VARLST *PARAMETERS-ALWAYS-OPTIONAL*) (PUSH (QUOTE &OPTIONAL) NEW-VARLST)) (IL:BQUOTE (DEFUN (IL:\\\, NAME) ((IL:\\\,@ NEW-VARLST) (IL:\\\,@ (AND *ADD-REST-ARG* (QUOTE (&REST $EXTRA-ARGS$))))) (IL:\\\,@ (AND *ADD-REST-ARG* (QUOTE ((DECLARE (IGNORE $EXTRA-ARGS$)))))) (IL:\\\,@ (MAPCONVERT (CDDR DEFN))))))) (LET ((*LOCALS* (ACONS VARLST :LOCAL NIL))) (IL:BQUOTE (DEFUN (IL:\\\, NAME) (&REST $ARGS$ &AUX ((IL:\\\, VARLST) (LENGTH $ARGS$))) (IL:\\\,@ (MAPCONVERT (CDDR DEFN)))))))) (IL:NLAMBDA (IF (LISTP VARLST) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST :TYPE :MACRO-ARG) (LET ((*LOCALS* (COPY-LIST VARNAMES))) (WHEN NEW-VARLST (PUSH (QUOTE &OPTIONAL) NEW-VARLST)) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) ((IL:\\\,@ NEW-VARLST) &REST $EXTRA-ARGS$) (DECLARE (IGNORE $EXTRA-ARGS$)) (IL:\\\, (MAKE-BQ (PROGN-IF-NEEDED (MAPCONVERT (CDDR DEFN))))))))) (LET ((*LOCALS* (ACONS VARLST :MACRO-ARG NIL))) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) (&REST (IL:\\\, VARLST)) (IL:\\\, (MAKE-BQ (PROGN-IF-NEEDED (MAPCONVERT (CDDR DEFN)))))))))) (T (ERROR "Unknown DEFINEQ type ~a" (FIRST DEFN)))))) (VALUES CONVERSION (NREVERSE *CURRENT-FUNCTION-CALLS*) (NREVERSE *CURRENT-FREE-REFERENCES*)))) + +(DEFUN CONVERT-CONSTANTS (VARS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (V) (IF (CONSP V) (IL:BQUOTE (DEFCONSTANT (IL:\\\, (FIRST V)) (IL:\\\, (SECOND V)))) (IL:BQUOTE (DEFCONSTANT (IL:\\\, V) (IL:\\\, (IL:KWOTE (SYMBOL-VALUE V)))))))) VARS))) + +(DEFUN CONVERT-INITVARS (VARS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (V) (IF (CONSP V) (AND (NOT (EQ (CAR V) (QUOTE IL:*))) (IL:BQUOTE (DEFVAR (IL:\\\, (FIRST V)) (IL:\\\, (SECOND V))))) (IL:BQUOTE (DEFVAR (IL:\\\, V) NIL))))) VARS))) + +(DEFUN CONVERT-VARS (VARS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (LET ((*CURRENT-DEFINTION-TYPE* "Variable")) (CONS (QUOTE PROGN) (DELETE (QUOTE NIL) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (V) (LET ((*CURRENT-DEFINITION* V)) (IF (CONSP V) (AND (NOT (EQ (CAR V) (QUOTE IL:*))) (IL:BQUOTE (DEFPARAMETER (IL:\\\, (NOTE-EXPORTED-SYMBOL (FIRST V))) (IL:\\\, (CONVERT (SECOND V)))))) (IF (BOUNDP V) (IL:BQUOTE (DEFPARAMETER (IL:\\\, (NOTE-EXPORTED-SYMBOL V)) (IL:\\\, (IL:KWOTE (SYMBOL-VALUE V))))) (PROGN (WARN "Var ~s not bound; no form dumped." V) NIL)))))) VARS))))) + +(DEFUN CONVERT-MACROS (FNS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (CONS (QUOTE PROGN) (DELETE (QUOTE NIL) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (F &AUX TEMPLATE) (WHEN (OR (SETQ TEMPLATE (GET F (QUOTE IL:MACRO))) (SETQ TEMPLATE (GET F (QUOTE IL:DMACRO)))) (LET ((*CURRENT-DEFINITION* F) (*CURRENT-DEFINITION-TYPE* "Macro")) (DEFINE-MACRO F TEMPLATE))))) FNS)))) + +(DEFUN CONVERT-ADDVARS (LISTS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (L) (IL:BQUOTE (SETQ (IL:\\\, (CAR L)) (LIST* (QUOTE (IL:\\\, (CDR L))) (AND (BOUNDP (QUOTE (IL:\\\, (CAR L)))) (IL:\\\, (CAR L)))))))) LISTS))) + +(DEFUN CONVERT-APPENDVARS (LISTS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (L) (IL:BQUOTE (SETQ (IL:\\\, (CAR L)) (APPEND (AND (BOUNDP (QUOTE (IL:\\\, (CAR L)))) (IL:\\\, (CAR L))) (QUOTE (IL:\\\, (CDR L)))))))) LISTS))) + +(DEFUN CONVERT-ALISTS (LISTS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (L &AUX (SYM (CAR L)) (KEYS (CDR L))) (LABELS ((DOTAIL (TAIL) (IL:BQUOTE (ACONS (QUOTE (IL:\\\, (CAR TAIL))) (QUOTE (IL:\\\, (CDR (ASSOC (CAR TAIL) (SYMBOL-VALUE SYM))))) (IL:\\\, (IF (ENDP (CDR TAIL)) (IL:BQUOTE (AND (BOUNDP (QUOTE (IL:\\\, SYM))) (IL:\\\, SYM))) (DOTAIL (CDR TAIL)))))))) (IL:BQUOTE (SETQ (IL:\\\, SYM) (IL:\\\, (DOTAIL KEYS))))))) LISTS))) + +(DEFUN CONVERT-PROP (STUFF &OPTIONAL MAPPING-FN-IGNORED) (DECLARE (IGNORE MAPPING-FN-IGNORED)) (LET* ((INDICATOR (FIRST STUFF)) (INDICATORS (IF (CONSP INDICATOR) INDICATOR (CONS INDICATOR NIL))) (SYMS (CDR STUFF)) (FORM (SECOND SYMS)) (IL:* IL:\; "if indirect...") (NOPROPVALUE (CONS NIL NIL))) (WHEN (EQ (FIRST SYMS) (QUOTE IL:*)) (IL:* IL:|;;| "indirect...") (SETQ SYMS (IL:EVAL FORM))) (MAPCAN-INTO-CONTEXT (QUOTE SETF) (FUNCTION (LAMBDA (S) (MAPCAN (FUNCTION (LAMBDA (I) (LET ((VALUE (GET S I NOPROPVALUE))) (WHEN (EQ VALUE NOPROPVALUE) (WARN "No ~s property for ~s" I S) (SETQ VALUE NIL)) (IL:BQUOTE ((GET (QUOTE (IL:\\\, S)) (QUOTE (IL:\\\, I))) (IL:\\\, (IL:KWOTE VALUE))))))) INDICATORS))) SYMS))) + +(DEFUN CONVERT-PROPS (PAIRS &AUX (NOPROPVALUE (CONS NIL NIL))) (DECLARE (IGNORE MAPPING-FN-IGNORED)) (MAPCAN-INTO-CONTEXT (QUOTE SETF) (FUNCTION (LAMBDA (P) (LET ((S (FIRST P)) (I (SECOND P))) (LET ((VALUE (GET S I NOPROPVALUE))) (WHEN (EQ VALUE NOPROPVALUE) (WARN "No ~s property for ~s" I S) (SETQ VALUE NIL)) (IL:BQUOTE ((GET (QUOTE (IL:\\\, S)) (QUOTE (IL:\\\, I))) (IL:\\\, (IL:KWOTE VALUE)))))))) PAIRS)) + +(DEFUN CONVERT-IFPROP (STUFF &OPTIONAL MAPPING-FN-IGNORED) (DECLARE (IGNORE MAPPING-FN-IGNORED)) (LET* ((INDICATOR (FIRST STUFF)) (INDICATORS (IF (CONSP INDICATOR) INDICATOR (CONS INDICATOR NIL))) (SYMS (CDR STUFF)) (FORM (SECOND SYMS)) (IL:* IL:\; "if indirect") (NOPROPVALUE (CONS NIL NIL))) (WHEN (EQ (FIRST SYMS) (QUOTE IL:*)) (SETQ SYMS (IL:EVAL FORM))) (MAPCAN (QUOTE SETF) (FUNCTION (LAMBDA (S) (MAPCAN (FUNCTION (LAMBDA (I) (BLOCK NIL (LET ((VALUE (GET S I NOPROPVALUE))) (WHEN (EQ VALUE NOPROPVALUE) (WARN "No ~s property for ~s" I S) (RETURN NIL)) (IL:BQUOTE ((GET (QUOTE (IL:\\\, S)) (QUOTE (IL:\\\, I))) (IL:\\\, (IL:KWOTE VALUE)))))))) INDICATORS))) SYMS))) + +(DEFUN CONVERT-RECORDS (RECS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (DECLARE (SPECIAL IL:USERRECLST)) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (R) (LET* ((DECL (CAR (IL:\\RECORDBLOCK/RECLOOK1 R IL:USERRECLST)))) (CONVERT DECL)))) RECS))) + +(DEFUN CONVERT-FILES-FILECOM (FILES &AUX (NOERRORS)) (WHEN (MEMBER (QUOTE COMPILE) *EVAL-WHEN-STATE*) (IL:DOFILESLOAD FILES)) (UNLESS (NULL (INTERSECTION (QUOTE (LOAD EVAL)) *EVAL-WHEN-STATE*)) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (F) (COND ((CONSP F) (WHEN (MEMBER (QUOTE IL:NOERRORS) F) (SETQ NOERRORS T)) (LET ((UNSUP (REMOVE (QUOTE IL:NOERRORS) F))) (WHEN UNSUP (WARN "FILES options not supported: ~:@(~{~A ~}~)" UNSUP)))) (T (TRANSLATOR-NOTE-ADDITIONAL-FILE F) (IL:BQUOTE (LOAD (IL:\\\, (STRING F)) (IL:\\\,@ (AND NOERRORS (QUOTE (:IF-DOES-NOT-EXIST NIL)))))))))) FILES)))) + +(DEFUN CONVERT-TOP-LEVEL-FORM-FILECOM (FORMS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (QUOTE CONVERT) FORMS))) + +(DEFUN CONVERT-COMMENT-FILECOM (BODY) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (B) (CONS (QUOTE IL:*) BODY))) (LIST BODY))) + +(DEFUN CONVERT-COMS-FILECOM (COMS) (MAPC (QUOTE CONVERT-ONE-FILECOM) COMS)) + +(DEFUN CONVERT-DECLARE-FILECOM (ARGS) (DO ((FORMS NIL) (EVAL-WHEN-EVAL (MEMBER (QUOTE EVAL) *EVAL-WHEN-STATE*)) (EVAL-WHEN-COMPILE (MEMBER (QUOTE COMPILE) *EVAL-WHEN-STATE*)) (EVAL-WHEN-LOAD (MEMBER (QUOTE LOAD) *EVAL-WHEN-STATE*)) (FIRST NIL) (TMPFORMS NIL) (FIRSTFORMS NIL) ARG) NIL (WHEN (AND TMPFORMS (OR (ENDP ARGS) (ATOM (FIRST ARGS)))) (LET* ((NEW-EVAL-WHEN-STATE (IL:BQUOTE ((IL:\\\,@ (IF EVAL-WHEN-EVAL (QUOTE (EVAL)))) (IL:\\\,@ (IF EVAL-WHEN-COMPILE (QUOTE (COMPILE)))) (IL:\\\,@ (IF EVAL-WHEN-LOAD (QUOTE (LOAD))))))) (OLD-EVAL-WHEN-STATE *EVAL-WHEN-STATE*) (*EVAL-WHEN-STATE* NEW-EVAL-WHEN-STATE) (OLD-LAST-CONS (AND *FILE-CONTEXT* (FILE-CONTEXT-DEFINITIONS-LAST-CONS *FILE-CONTEXT*)))) (IL:* IL:|;;| "The way things are dropped directly into the context, we need to re-group them by performing some micro-surgery on the list structure on the fly.") (MAPC (QUOTE CONVERT-ONE-FILECOM) (NREVERSE TMPFORMS)) (WHEN *FILE-CONTEXT* (IF (NULL OLD-LAST-CONS) (IL:* IL:|;;| "This com was the first one... special case...") (LET ((NEW-FORM (CONS (IL:BQUOTE (EVAL-WHEN (IL:\\\, NEW-EVAL-WHEN-STATE) (IL:\\\,@ (FILE-CONTEXT-DEFINITIONS *FILE-CONTEXT*)))) NIL))) (SETF (FILE-CONTEXT-DEFINITIONS *FILE-CONTEXT*) NEW-FORM) (FILE-CONTEXT-DEFINITIONS-LAST-CONS *FILE-CONTEXT*) NEW-FORM) (IL:* IL:|;;| " Not the first com in the file...") (SETF (CDR OLD-LAST-CONS) (IL:BQUOTE ((EVAL-WHEN (IL:\\\, NEW-EVAL-WHEN-STATE) (IL:\\\,@ (CDR OLD-LAST-CONS))))) (FILE-CONTEXT-DEFINITIONS-LAST-CONS *FILE-CONTEXT*) (LAST OLD-LAST-CONS))))) (IF FIRST (PUSH TMPFORMS FIRSTFORMS) (PUSH TMPFORMS FORMS)) (SETQ TMPFORMS NIL)) (WHEN (ENDP ARGS) (RETURN)) (SETQ ARG (POP ARGS)) (IF (ATOM ARG) (CASE ARG ((IL:EVAL@LOAD IL:DOEVAL@LOAD) (SETQ EVAL-WHEN-EVAL T)) (IL:DONTEVAL@LOAD (SETQ EVAL-WHEN-EVAL NIL)) (IL:EVAL@LOADWHEN (SETQ EVAL-WHEN-EVAL (EVAL (POP ARGS)))) ((IL:EVAL@COMPILE IL:DOEVAL@COMPILE) (SETQ EVAL-WHEN-COMPILE T)) (IL:DONTEVAL@COMPILE (SETQ EVAL-WHEN-COMPILE NIL)) (IL:EVAL@COMPILEWHEN (SETQ EVAL-WHEN-COMPILE (EVAL (POP ARGS)))) ((IL:COPY IL:DOCOPY) (SETQ EVAL-WHEN-LOAD T)) (IL:DONTCOPY (SETQ EVAL-WHEN-LOAD NIL)) (IL:COPYWHEN (SETQ EVAL-WHEN-LOAD (EVAL (POP ARGS)))) (IL:FIRST (WARN "\"FIRST\" option in DECLARE: was ignored.")) (IL:NOTFIRST (SETQ FIRST NIL)) (T (WARN "Unknown option ~:@(~a~) in DECLARE:" ARG))) (PUSH ARG TMPFORMS)))) + +(DEFUN CONVERT-EXPORT-FILECOM (COM &OPTIONAL MAPPING-FN-IGNORED) (DECLARE (IGNORE MAPPING-FN-IGNORED)) NIL) + +(DEFUN CONVERT-FUNCTIONS-FILECOM (FUNCTIONS) (IL:* IL:|;;| "Use the Code-Walker (stolen from Gregor's PCL) to hunt down any lingering IL code in CL functions...") (FLET ((CONVERT-FUNCTION (F) (LET* ((DEF (FUNCALL (GET (QUOTE IL:FUNCTIONS) (QUOTE IL:GETDEF)) F (QUOTE IL:FUNCTIONS))) (IL:* IL:|;;| " The def name will be added by the template walker...") (*CURRENT-FUNCTION-CALLS* NIL) (*CURRENT-FREE-REFERENCES* NIL) (*CURRENT-DEFINITION* NIL) (*CURRENT-DEFINITION-TYPE* "Function") (CONVERSION (WALK-FORM-INTERNAL DEF))) (VALUES CONVERSION (NREVERSE *CURRENT-FUNCTION-CALLS*) (NREVERSE *CURRENT-FREE-REFERENCES*))))) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (FUNCTION CONVERT-FUNCTION) FUNCTIONS)))) + +(DEFUN CONVERT-ONE-BITMAP (VARNAME) (LET* ((B (SYMBOL-VALUE VARNAME)) (A (MAKE-ARRAY (LIST (IL:BITMAPHEIGHT B) (IL:BITMAPWIDTH B)) :ELEMENT-TYPE (QUOTE BIT)))) (IL:* IL:|;;| "Oughta be a better way...") (IL:FOR J IL:TO (IL:BITMAPWIDTH B) IL:DO (IL:FOR I IL:TO (IL:BITMAPHEIGHT B) IL:DO (SETF (AREF A (1- I) (1- J)) (IL:BITMAPBIT B J I)))) (IL:* IL:|;;| "This must print out with *print-array* on.") (IL:BQUOTE (DEFPARAMETER (IL:\\\, VARNAME) (QUOTE (IL:\\\, A)))))) + +(DEFUN CONVERT-BITMAPS (VARS) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (QUOTE CONVERT-ONE-BITMAP) VARS))) + +(DEFUN CONVERT-VARIABLES-FILECOM (VARS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR)) &AUX (GETD (GET (QUOTE IL:VARIABLES) (QUOTE IL:GETDEF)))) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (V) (FUNCALL GETD V (QUOTE IL:VARIABLES)))) VARS))) + +(DEFUN CONVERT-STRUCTURES-FILECOM (STRUCTURES &OPTIONAL (MAPPING-FN (QUOTE MAPCAR)) &AUX (GETD (GET (QUOTE IL:STRUCTURES) (QUOTE IL:GETDEF)))) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (S) (FUNCALL GETD S (QUOTE IL:STRUCTURES)))) STRUCTURES))) + + + +(IL:* IL:|;;| "Conversion functions for filecom types are noted on the plists of their names.") + + +(IL:PUTPROPS IL:FNS CONVERT-COM CONVERT-FNS) + +(IL:PUTPROPS IL:CONSTANTS CONVERT-COM CONVERT-CONSTANTS) + +(IL:PUTPROPS IL:INITVARS CONVERT-COM CONVERT-INITVARS) + +(IL:PUTPROPS IL:VARS CONVERT-COM CONVERT-VARS) + +(IL:PUTPROPS IL:MACROS CONVERT-COM CONVERT-MACROS) + +(IL:PUTPROPS IL:ADDVARS CONVERT-COM CONVERT-ADDVARS) + +(IL:PUTPROPS IL:APPENDVARS CONVERT-COM CONVERT-APPENDVARS) + +(IL:PUTPROPS IL:ALISTS CONVERT-COM CONVERT-ALISTS) + +(IL:PUTPROPS IL:PROP CONVERT-COM CONVERT-PROP) + +(IL:PUTPROPS IL:PROPS CONVERT-COM CONVERT-PROPS) + +(IL:PUTPROPS IL:IFPROP CONVERT-COM CONVERT-IFPROP) + +(IL:PUTPROPS IL:RECORDS CONVERT-COM CONVERT-RECORDS) + +(IL:PUTPROPS IL:INITRECORDS CONVERT-COM CONVERT-RECORDS) + +(IL:PUTPROPS IL:FILES CONVERT-COM CONVERT-FILES-FILECOM) + +(IL:PUTPROPS IL:P CONVERT-COM CONVERT-TOP-LEVEL-FORM-FILECOM) + +(IL:PUTPROPS IL:* CONVERT-COM CONVERT-COMMENT-FILECOM) + +(IL:PUTPROPS IL:COMS CONVERT-COM CONVERT-COMS-FILECOM) + +(IL:PUTPROPS IL:DECLARE\: CONVERT-COM CONVERT-DECLARE-FILECOM) + +(IL:PUTPROPS EXPORT CONVERT-COM CONVERT-COMS-FILECOM) + +(IL:PUTPROPS IL:FUNCTIONS CONVERT-COM CONVERT-FUNCTIONS-FILECOM) + +(IL:PUTPROPS IL:VARIABLES CONVERT-COM CONVERT-VARIABLES-FILECOM) + +(IL:PUTPROPS IL:STRUCTURES CONVERT-COM CONVERT-STRUCTURES-FILECOM) + +(IL:PUTPROPS IL:SETFS CONVERT-COM CONVERT-SETFS-FILECOM) + +(IL:PUTPROPS IL:BITMAPS CONVERT-COM CONVERT-BITMAPS) + + + +(IL:* IL:|;;| "Magic to make comments print out in the usual way...") + + +(DEFSTRUCT (IL-COMMENT-STRUCT (:PRINT-FUNCTION PRINT-IL-COMMENT-STRUCT)) STUFF) + +(DEFUN PRINT-IL-COMMENT-STRUCT (O S D) (LET ((STUFF (IL-COMMENT-STRUCT-STUFF O))) (COND ((SOME (FUNCTION (LAMBDA (X) (AND (CONSP X) (SOME (QUOTE CONSP) X)))) STUFF) (IL:* IL:|;;| "Commenting out a form? Try it this way...") (PRINC "#||" S) (PRIN1 STUFF S) (PRINC "||#" S)) (T (UNLESS (AND (TYPEP (FIRST STUFF) (QUOTE (OR SYMBOL STRING))) (EQL (CHAR (STRING (FIRST STUFF)) 0) #\;)) (PRINC "; " S)) (DOLIST (I STUFF) (PRINC I S) (WRITE-CHAR #\Space S)) (TERPRI S))))) + +(IL-DEFCONV * (&REST STUFF) (IF (AND (MEMBER (CAR STUFF) (QUOTE (IL:\; IL:|;;| IL:|;;;| IL:|;;;;| IL:\#\|))) (STRINGP (SECOND STUFF)) (NULL (CDDR STUFF))) (CONS (QUOTE IL:*) STUFF) (LET ((STR (FORMAT NIL "~{~a ~}" STUFF))) (LIST (QUOTE IL:*) (IF (< (LENGTH STR) 32) (QUOTE IL:\;) (QUOTE IL:|;;|)) STR)))) + +(IL:PUTPROPS IL:IL-SIM IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (IN-PACKAGE "IL-CONVERT") *PACKAGE*) :BASE 10) +) + +(IL:PUTPROPS IL:IL-SIM IL:FILETYPE :COMPILE-FILE) +(IL:PUTPROPS IL:IL-SIM IL:COPYRIGHT ("ENVOS Corporation" 1989 1990)) +(IL:DECLARE\: IL:DONTCOPY + (IL:FILEMAP (NIL))) +IL:STOP diff --git a/lispusers/MIGRATION/IL-SIM.LCOM b/lispusers/MIGRATION/IL-SIM.LCOM new file mode 100644 index 00000000..3dc6a7dc --- /dev/null +++ b/lispusers/MIGRATION/IL-SIM.LCOM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (CLIN-PACKAGE "IL-CONVERT") *PACKAGE*) BASE 10) (IL:FILECREATED "19-Jan-93 19:55:31" ("compiled on " IL:|{DSK}local>src>tape>MIGRATION>IL-SIM.;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 "25-Jan-90 11:04:43" IL:|{DSK}/users/welch/migration/IL-SIM.;3| 88504 IL:|changes| IL:|to:| (IL:FUNCTIONS NTHCHARCODE ERROR) IL:|previous| IL:|date:| "25-Jan-90 08:58:55" IL:|{DSK}/users/welch/migration/IL-SIM.;2|) (IL:PRETTYCOMPRINT IL:IL-SIMCOMS) (IL:RPAQQ IL:IL-SIMCOMS ((IL:* IL:|;;| "Converter macros Have to add \"CL\" as a nickname to the LISP package since some Interlisp code names it that way." ) (IL:P (IN-PACKAGE (QUOTE IL-CONVERT))) (IL:FUNCTIONS CONVERT-TO-STRING SIMP-MINUS SIMP-1- QUOTE-TREE EXPAND-VARLIST) (IL:FUNCTIONS RPAQQ RPAQ RPAQ?) (IL:FUNCTIONS CONSTANTS) (IL:* IL:\| "chapter 2") ( IL:VARIABLES *WARN-FOR-ALL-IL-SYMBOLS* *WARN-FOR-IL-SYMBOLS-LOWER-THAN-THIS* *WARN-ON-CHAR-CODE-USE*) (IL:P (IL-COPYDEF ATOM) (IL-COPYDEF BOUNDP) (IL-COPYDEF SET)) (IL:FUNCTIONS LITATOM SETQQ SETQ PSETQ) (IL:FUNCTIONS (IL:* IL:\; "warning forms") IL:GETTOPVAL IL:SETTOPVAL) (IL:* IL:|;;| "with Franz, might want to use mp:global-symbol-value for the following") (IL:P (IL-COPYDEF SET SETATOMVAL)) (IL:FUNCTIONS GETATOMVAL GETPROP PUTPROP ADDPROP) (IL:FUNCTIONS REMPROP REMPROPLIST CHANGEPROP) (IL:FUNCTIONS (IL:* IL:\; "warning forms") IL:PROPNAMES IL:DEFLIST) (IL:P (IL-COPYDEF SYMBOL-PLIST GETPROPLIST) (IL-COPYDEF GENTEMP GENSYM)) (IL:FUNCTIONS MKATOM L-CASE U-CASE) (IL:FUNCTIONS SETPROPLIST CHARCODE NTHCHARCODE CHARACTER CHCON1 EVAL-IF-POSSIBLE SELCHARQ) (IL:P (IL-COPYCONV CHARACTER FCHARACTER)) (IL:FUNCTIONS (IL:* IL:\; "warning forms") IL:PACK IL:PACK* IL:UNPACK IL:DUNPACK IL:MAPATOMS IL:APROPOS) (IL:* IL:\; "***** rest of chapter 2") (IL:* IL:\| "Chapter 3") (IL:FUNCTIONS NLISTP) (IL:* IL:\; "***** CAR/CDRERR") (IL:P (IL-COPYDEF CONS) (IL-COPYDEF LISTP) (IL-COPYDEF CAR) ( IL-COPYDEF CDR) (IL-COPYDEF CADR) (IL-COPYDEF CDAR) (IL-COPYDEF CDDR) (IL-COPYDEF CAAAR) (IL-COPYDEF CAADR) (IL-COPYDEF CADAR) (IL-COPYDEF CADDR) (IL-COPYDEF CDAAR) (IL-COPYDEF CDADR) (IL-COPYDEF CDDAR) (IL-COPYDEF CDDDR) (IL-COPYDEF CAAAAR) (IL-COPYDEF CAAADR) (IL-COPYDEF CAADAR) (IL-COPYDEF CAADDR) ( IL-COPYDEF CADAAR) (IL-COPYDEF CDDDAR) (IL-COPYDEF CDDDDR) (IL-COPYDEF RPLACD) (IL-COPYDEF RPLACD FRPLACD) (IL-COPYDEF RPLACA) (IL-COPYDEF RPLACA FRPLACA)) (IL:FUNCTIONS RPLNODE RPLNODE2 FRPLNODE FRPLNODE2 MKLIST NCONC1) (IL:P (IL-COPYDEF LIST) (IL-COPYDEF LIST*) (IL-COPYDEF APPEND) (IL-COPYDEF NCONC) (IL-COPYDEF TAILP) (IL-COPYDEF LAST) (IL-COPYDEF LENGTH) (IL-COPYDEF LENGTH FLENGTH) ( IL-COPYDEF SET-DIFFERENCE LDIFFERENCE) (IL-COPYDEF INTERSECTION) (IL-COPYDEF UNION)) (IL:FUNCTIONS ATTACH LCONC TCONC) (IL:FUNCTIONS IL:DOCOLLECT IL:ENDCOLLECT IL:SCRATCHLIST IL:ADDTOSCRATCHLIST IL:COPYALL IL:HCOPYALL IL:NLEFT IL:LASTN IL:COUNT IL:COUNTDOWN IL:EQUALN IL:LDIFF IL:LSUBST IL:SUBPAIR ) (IL:* IL:\; "warning forms ") (IL:P (IL-COPYDEF COPY-LIST COPY)) (IL:FUNCTIONS NTH MEMB FMEMB MEMBER EQMEMB SUBST DSUBST SUBLIS DSUBLIS ASSOC SASSOC PUTASSOC) (IL:P (IL-COPYCONV NTH FNTH) (IL-COPYCONV LAST FLAST) (IL-COPYCONV MEMB FMEMB) (IL-COPYCONV ASSOC FASSOC) (IL-COPYDEF GETF LISTGET)) (IL:FUNCTIONS LISTPUT LISTGET1 MERGE) (IL:FUNCTIONS IL:LISTPUT1 IL:ALPHORDER IL:UALPHORDER IL:COMPARELISTS) (IL:* IL:\; "warning forms") (IL:FUNCTIONS REMOVE DREMOVE REVERSE DREVERSE) (IL:FUNCTIONS NEGATE) (IL:* IL:\| "chapter 4") (IL:P (IL-COPYDEF STRINGP)) (IL:FUNCTIONS STREQUAL STRING-EQUAL NCHARS ALLOCSTRING MKSTRING CONCAT CONCATLIST RPLSTRING RPLCHARCODE STRPOS SUBSTRING) (IL:* IL:|;;| " Warning Forms") ( IL:FUNCTIONS IL:GNC IL:GLC) (IL:* IL:\| "chapter 5") (IL:* IL:\; "***** chapter 5 (arrays)") (IL:* IL:\| "chapter 6") (IL:FUNCTIONS MAPHASH GETHASH PUTHASH) (IL:* IL:\; "***** chapter 6 (hash arrays)") (IL:* IL:\| "chapter 7") (IL:FUNCTIONS SMALLP) (IL:* IL:\; "*** ??") (IL:FUNCTIONS FIXP) (IL:P (IL-COPYDEF FLOATP) (IL-COPYDEF NUMBERP) (IL-COPYDEF EQUALP EQP)) (IL:* IL:|;;| "(il-defconv EQP (x y) `(eql ,^x ,^y)) ***** overflow") (IL:FUNCTIONS PLUS MINUS DIFFERENCE TIMES) (IL:* IL:\; "***** remainder ") (IL:FUNCTIONS GREATERP LESSP GEQ LEQ) (IL:P (IL-COPYDEF ZEROP) (IL-COPYDEF MINUSP) (IL-COPYDEF MIN) (IL-COPYDEF MAX) (IL-COPYDEF ABS)) (IL:* IL:\; "***** min.integer,^ max.integer") (IL:FUNCTIONS IPLUS IMINUS IDIFFERENCE ADD1 SUB1 ITIMES IQUOTIENT IREMAINDER IMOD IGREATERP ILESSP IGEQ ILEQ IMIN IMAX IEQP FIX FIXR RSH POWEROFTWOP EVENP ODDP BITTEST BITCLEAR) (IL:P (IL-COPYDEF GCD) (IL-COPYDEF LOGAND) (IL-COPYDEF LOGIOR LOGOR) (IL-COPYDEF ASH LSH) ( IL-COPYDEF INTEGER-LENGTH INTEGERLENGTH) (IL-COPYDEF LOGNOT) (IL-COPYDEF LOGIOR BITSET)) (IL:FUNCTIONS MASK.1\'S MASK.0\'S LOADBYTE DEPOSITBYTE) (IL:P (IL-COPYDEF BYTE) (IL-COPYDEF BYTE-SIZE BYTESIZE) ( IL-COPYDEF BYTE-POSITION BYTEPOSITION) (IL-COPYDEF LDB) (IL-COPYDEF DPB)) (IL:FUNCTIONS (IL:* IL:\; "warning forms") IL:ROT) (IL:* IL:|;;| " *** section 7.4 (floating point)") (IL:* IL:\| "chapter 8") (IL:* IL:|;;| " **** Record stuff in IL-RECORD.lisp *** Changetran...") (IL:FUNCTIONS |push| |add| |change| |pushnew| |pushlist| |swap|) (IL:P (IL-COPYCONV |push| PUSH) (IL-COPYCONV |add| ADD) ( IL-COPYCONV |change| CHANGE) (IL-COPYCONV |pushnew| PUSHNEW) (IL-COPYCONV |pushlist| PUSHLIST) ( IL-COPYCONV |swap| SWAP) (IL-COPYDEF POP) (IL-COPYDEF POP |pop|)) (IL:* IL:\| "chapter 9") (IL:* IL:\; "**** 9.1") (IL:P (IL-COPYDEF EQ) (IL-COPYDEF NULL) (IL-COPYDEF NOT) (IL-COPYDEF EQUAL) (IL-COPYDEF AND) (IL-COPYDEF OR)) (IL:FUNCTIONS NEQ) (IL:* IL:\; "EQP is in chapter 7") (IL:* IL:\; "***** EQUALALL") (IL:FUNCTIONS COND) (IL:* IL:|;;| " (convert '(il:cond ((il:geq 3 2) (il:times 2 3))))") (IL:FUNCTIONS |if|) (IL:P (IL-COPYCONV |if| IF) ) (IL:* IL:|;;| " (convert '(il:|if| (il:geq a b) il:|then| (foo) il:|elseif| (il:atom (il:plus 2 3)) il:|then| (bar) il:|else| (baz))) ") (IL:FUNCTIONS SELECTQ SELECTC CASE) (IL:* IL:|;;| " (convert '(il:selectq (il:plus 2 3) (a (il:times a b)) (il:plus c d))) ") (IL:* IL:\; "***** SELECTC") (IL:P (IL-COPYDEF PROG1) (IL-COPYDEF PROG2) (IL-COPYDEF PROGN) ( IL-COPYDEF RETURN) (IL-COPYDEF RETURN-FROM RETFROM)) (IL:* IL:|;;| "If we were really clever we could keep track of when we were inside a PROG. Then we could treat (top-level) symbols as prog labels and not put them in the IL package. In that case we would want GO to generate `(go ,tag) instead of `(go ,^tag)." ) (IL:FUNCTIONS GO PROG LET LET* PROG* CONVERT-DO CONVERT-DO*) (IL:P (IL:* IL:|;;| "One case where il-defconv won't do what we need...") (SETF (GET (QUOTE DO) (QUOTE CONVERT-FORM)) ( QUOTE CONVERT-DO) (GET (QUOTE DO*) (QUOTE CONVERT-FORM)) (QUOTE CONVERT-DO*))) (IL:* IL:|;;| "I.S. stuff - entry is coded into CONVERT") (IL:VARIABLES *ITERATION-CONVERSION-TABLE*) (IL:FUNCTIONS CONVERT-ITERATION-STATEMENT FILTER-NUMERIC-BY FILTER-LIST-BY FILTER-BIND FILTER-DO FILTER-INSTRING FILTER-REPEATWHILE/UNTIL) (IL:* IL:\| "chapter 10") (IL:* IL:|;;| "These variables can be set to T to make lambdas come out with &REST IGNORE (equiv.) and &OPTIONAL in their parm. lists." ) (IL:VARIABLES *ADD-REST-ARG* *PARAMETERS-ALWAYS-OPTIONAL*) (IL:FUNCTIONS DEFINEQ1 ARG SETARG DEFINEQ ) (IL:* IL:|;;| "(convert '(defineq (foo (lambda (a b) (plus a b c))))) (convert '(defineq (foo (nlambda (a b) (plus a b c))))) (convert '(defineq (foo (lambda x (plus (arg x 1) (arg x 2)))))) (convert '(defineq (foo (nlambda x (mapcar 'foo x))))) ***** FNTYP, EXPRP, CCODEP, ARGTYPE, NARGS, ARGLIST, SMARTARGLIST ***** DEFINE ***** UNSAVE.TO.MODIFY.FNS, DFNFLG" ) (IL:FUNCTIONS PUTD CCODEP) NIL (IL:P (IL-COPYDEF SYMBOL-FUNCTION GETD) (IL-COPYDEF APPLY) ( IL-COPYDEF FUNCALL APPLY*)) (IL:FUNCTIONS KWOTE) (IL:* IL:|;;| "(il-defconv QUOTE (&rest args) `(quote ,@args)) ***** NLAMBDA.ARGS,^ EVALA,^ DEFEVAL,^ EVALHOOK") ( IL:* IL:|;;| " ; is this right? (il-defconv RPTQ (n &rest forms) `(do ((IL::RPTN ,^(eval n) (1- IL::RPTN)) val) ((<= IL::RPTN 0) val) (declare (special IL::RPTN)) (setq val (progn ,@^@forms)))) ") (IL:* IL:\; "***** RPTQ, FRPTQ") (IL:FUNCTIONS MOVD MAP MAPC MAPLIST MAPCAR MAPCON MAPCONC MAP2C MAP2CAR SUBSET) (IL:* IL:\; "***** rest of chapter") (IL:FUNCTIONS IL:MOVD?) (IL:* IL:\| "chapter 14") (IL:VARIABLES *WARN-ON-ERSETQ-NLSETQ*) (IL:FUNCTIONS SHOULDNT ERROR NLSETQ ERSETQ) (IL:* IL:\| "chapter 17") (IL:VARIABLES *EVAL-WHEN-STATE*) (IL:FUNCTIONS DECLARE\:) (IL:FUNCTIONS PUTPROPS DEFINE-MACRO DEFINE-SUBST-MACRO QUOTE) (IL:* IL:|;;| "(il-defconv * (&rest args) `(il::* ,@args))") ( IL:* IL:|;;| "what are we supposed to do with (declare (specvars . t)) ?") (IL:VARIABLES *TYPE-CONVERSION-PLIST*) (IL:FUNCTIONS DECLARE FILEMAP ADDTOVAR APPENDTOVAR FUNCTION LAMBDA DEFINE-FILE-INFO PRETTYCOMPRINT) (IL:P (SETF (GET (QUOTE FILECREATED) (QUOTE EARLY)) T)) (IL:FUNCTIONS FILECREATED) (IL:* IL:\| "chapter 18") (IL:FUNCTIONS CONSTANT) (IL:* IL:\| "chapter 23") (IL:P ( IL-COPYDEF PROCESSP)) (IL:FUNCTIONS CREATE.MONITORLOCK OBTAIN.MONITORLOCK RELEASE.MONITORLOCK WITH.MONITOR NOTIFY.EVENT THIS.PROCESS) (IL:FUNCTIONS (IL:* IL:\; "warningforms...") IL:AWAIT.EVENT IL:CREATE.EVENT) (IL:* IL:\| "chapter 24") (IL:FUNCTIONS OPENSTRINGSTREAM) (IL:* IL:\| "chapter 25") ( IL:P (IL-COPYDEF PRINT) (IL-COPYDEF TERPRI) (IL-COPYDEF PRIN1 PRIN2) (IL-COPYDEF PRINC PRIN1) ( IL-COPYDEF READ-CHAR BIN) (IL-COPYDEF WRITE-CHAR BOUT)) (IL:VARIABLES *ANNOTATE-PRINTOUT-FORM*) ( IL:FUNCTIONS PRINTOUT READ READP) (IL:P (IL-COPYCONV PRINTOUT |printout|)) (IL:* IL:|;;| "Warning forms") (IL:FUNCTIONS IL:INPUT IL:RATOM IL:RSTRING IL:RATOMS IL:RATEST IL:READC IL:PEEKC IL:LASTC IL:READCCODE IL:PEEKCCODE IL:READP IL:EOFP IL:WAITFORINPUT IL:SKREAD IL:SKIPSEPRS IL:OUTPUT IL:PRIN3 IL:PRIN4 IL:PRINTCCODE IL:TAB IL:SHOWPRIN2 IL:SHOWPRINT IL:PRINTBELLS IL:LINELENGTH IL:SETLINELENGTH) (IL:* IL:\| "Unconvertable things...") (IL:* IL:|;;| "Warning forms") (IL:FUNCTIONS IL:WINDOWADDPROP IL:\\PUTBASE IL:\\GETBASE IL:DSPLEFTMARGIN IL:RESETLST IL:WINDOWPROP) (IL:FUNCTIONS IL:SMARTARGLIST IL:EDITGETD IL:FIND.PROCESS IL:PROCESS.EVALV IL:PROCESSP IL:PROCESS.EVAL IL:FREEMENU IL:FM.RESETMENU IL:FM.CHANGESTATE IL:FM.CHANGELABEL IL:FM.ITEMPROP IL:FM.EDITITEM IL:FM.GETITEM IL:MAINWINDOW IL:RESETFORM IL:SETTERMTABLE IL:PROCESSPROP IL:TTY.PROCESS IL:CLEARW IL:\\CARET.DOWN IL:\\SMASHSTRING IL:BKSYSBUF IL:CLEARBUF IL:GETSYNTAX IL:OPENWP IL:STRINGWIDTH IL:CHARWIDTH IL:FLASHWINDOW IL:MENU IL:FONTCREATE IL:TTYINPROMPTFORWORD IL:MOUSECONFIRM IL:CLOSEW IL:ATTACHWINDOW IL:SHAPEW IL:CONCATLIST IL:GETPROMPTWINDOW IL:BITBLT IL:BLTSHADE IL:BITMAPWIDTH IL:BITMAPHEIGHT IL:FONTPROP IL:TEDIT.INSERT IL:TEDIT.PARALOOKS IL:DSPCLIPPINGREGION IL:MOVETO IL:RELMOVETO IL:DSPFONT IL:DSPXPOSITION IL:CURSORCREATE IL:WAIT.FOR.TTY IL:\\SAVEVMEMBACKGROUND IL:GETREGION IL:WINDOWREGION IL:EVALV IL:TTY/EDITE IL:CLISPTRAN IL:TTY/EDITL IL:MARKASCHANGED IL:FIXEDITDATE IL:PUTDEF IL:ADDSPELL IL:PROCESS.APPLY IL:STKPOS IL:EDITMODE IL:TOTOPW IL:EXPANDW IL:ADD.PROCESS IL:INSIDEP IL:LASTMOUSEX IL:LASTMOUSEY IL:CREATEW IL:DSPLINEFEED IL:DSPRIGHTMARGIN IL:DOWINDOWCOM IL:TTY.PROCESSP IL:IN/SCROLL/BAR? IL:SCROLL.HANDLER IL:BLOCK IL:CLOCK IL:DSPXOFFSET IL:DSPYOFFSET IL:CREATEREGION IL:HEIGHTIFWINDOW IL:SCROLLW IL:WXOFFSET IL:WYOFFSET IL:KEYDOWNP IL:SHIFTDOWNP IL:UNTILMOUSESTATE IL:FIND-READTABLE IL:NILL IL:FILECOMS IL:ADDFILE IL:ADDTOFILE IL:READTABLEPROP IL:LINELENGTH IL:GETDEF ) (IL:* IL:\| "Filecom converters") (IL:FUNCTIONS CONVERT-FNS CONVERT-ONE-FN CONVERT-CONSTANTS CONVERT-INITVARS CONVERT-VARS CONVERT-MACROS CONVERT-ADDVARS CONVERT-APPENDVARS CONVERT-ALISTS CONVERT-PROP CONVERT-PROPS CONVERT-IFPROP CONVERT-RECORDS CONVERT-FILES-FILECOM CONVERT-TOP-LEVEL-FORM-FILECOM CONVERT-COMMENT-FILECOM CONVERT-COMS-FILECOM CONVERT-DECLARE-FILECOM CONVERT-EXPORT-FILECOM CONVERT-FUNCTIONS-FILECOM CONVERT-ONE-BITMAP CONVERT-BITMAPS CONVERT-VARIABLES-FILECOM CONVERT-STRUCTURES-FILECOM) (IL:* IL:|;;| "Conversion functions for filecom types are noted on the plists of their names.") (IL:PROP CONVERT-COM IL:FNS IL:CONSTANTS IL:INITVARS IL:VARS IL:MACROS IL:ADDVARS IL:APPENDVARS IL:ALISTS IL:PROP IL:PROPS IL:IFPROP IL:RECORDS IL:INITRECORDS IL:FILES IL:P IL:* IL:COMS IL:DECLARE\: EXPORT IL:FUNCTIONS IL:VARIABLES IL:STRUCTURES IL:SETFS IL:BITMAPS) (IL:* IL:|;;| "Magic to make comments print out in the usual way...") (IL:STRUCTURES IL-COMMENT-STRUCT) (IL:FUNCTIONS PRINT-IL-COMMENT-STRUCT *) (IL:PROP (IL:MAKEFILE-ENVIRONMENT IL:FILETYPE) IL:IL-SIM))) (IN-PACKAGE (QUOTE IL-CONVERT)) (DEFUN CONVERT-TO-STRING (S) (IF (STRINGP S) S (IL:BQUOTE (STRING (IL:\\\, S))))) (DEFUN SIMP-MINUS (N) (IF (NUMBERP N) (- N) (IL:BQUOTE (- (IL:\\\, N))))) (DEFUN SIMP-1- (N) (IF (NUMBERP N) (1- N) (IL:BQUOTE (1- (IL:\\\, N))))) (DEFUN QUOTE-TREE (ARG) (COND ((CONSP ARG) (CONS (QUOTE-TREE (CAR ARG)) (QUOTE-TREE (CDR ARG)))) (( SYMBOLP ARG) (IL:* IL:|;;| "Macros sometimes have (if 'macroarg...) in them.") (IF (EQ (CDR (ASSOC ARG *LOCALS*)) :MACRO-ARG) (MAKE-MACRO-ARG :ELEMENT ARG) (NOTE-EXPORTED-SYMBOL ARG))) (T ARG))) (DEFUN EXPAND-VARLIST (VARLST &KEY SEQUENTIAL (TYPE :LOCAL)) (DECLARE (SPECIAL *LOCALS*)) (DO ((VARLST VARLST (REST VARLST)) (*LOCALS* *LOCALS*) (NEW-VARLST NIL) (VARNAMES NIL) VAR VARNAME) ((ENDP VARLST) (VALUES (NREVERSE NEW-VARLST) VARNAMES)) (DECLARE (SPECIAL *LOCALS*)) (SETQ VAR (FIRST VARLST)) (COND ((CONSP VAR) (SETQ VARNAME (FIRST VAR)) (PUSH (IL:BQUOTE ((IL:\\\, VARNAME) (IL:\\\,@ (MAPCONVERT ( REST VAR))))) NEW-VARLST)) (T (SETQ VARNAME VAR) (PUSH VAR NEW-VARLST))) (SETQ VARNAME (CONS VARNAME TYPE)) (PUSH VARNAME VARNAMES) (WHEN SEQUENTIAL (PUSH VARNAME *LOCALS*)))) (IL-DEFCONV RPAQQ (&REST PAIRS) (DO ((PAIRS PAIRS (REST (REST PAIRS))) SYM (NEWPAIRS NIL)) ((ENDP PAIRS) (IL:BQUOTE (SETQ (IL:\\\,@ (NREVERSE NEWPAIRS))))) (SETQ SYM (CONVERT (FIRST PAIRS))) (PUSH SYM NEWPAIRS) (PUSHNEW SYM *GLOBALS*) (PUSH (CONVERT (IL:BQUOTE (QUOTE (IL:\\\, (SECOND PAIRS))))) NEWPAIRS))) (IL-DEFCONV RPAQ (&REST PAIRS) (DO ((PAIRS PAIRS (REST (REST PAIRS))) SYM (NEWPAIRS NIL)) ((ENDP PAIRS ) (IL:BQUOTE (SETQ (IL:\\\,@ (NREVERSE NEWPAIRS))))) (SETQ SYM (CONVERT (FIRST PAIRS))) (PUSH SYM NEWPAIRS) (PUSHNEW SYM *GLOBALS*) (PUSH (IL:BQUOTE (IL:\\\, (CONVERT (SECOND PAIRS)))) NEWPAIRS))) (IL-DEFCONV RPAQ? (VAR &OPTIONAL (VALUE NIL SVAR) &REST OTHER-ARGS) (DECLARE (IGNORE OTHER-ARGS)) ( CHECK-TYPE VAR SYMBOL) (LET ((SYM (CONVERT VAR))) (PUSHNEW SYM *GLOBALS*) (IF SVAR (IL:BQUOTE (DEFVAR (IL:\\\, SYM) (IL:\\\, (CONVERT VALUE)))) (IL:BQUOTE (DEFVAR (IL:\\\, SYM)))))) (IL-DEFCONV CONSTANTS (&REST VARS-VALS) (PROGN-IF-NEEDED (MAP (QUOTE LIST) (FUNCTION (LAMBDA (F) (IF ( CONSP F) (IL:BQUOTE (DEFCONSTANT (IL:\\\, (CONVERT (CAR F))) (IL:\\\, (CONVERT (CADR F))))) (IL:BQUOTE (DEFCONSTANT (IL:\\\, (CONVERT F)) (IL:\\\, (CONVERT F))))))) VARS-VALS))) (DEFVAR *WARN-FOR-ALL-IL-SYMBOLS* NIL) (DEFPARAMETER *WARN-FOR-IL-SYMBOLS-LOWER-THAN-THIS* NIL) (DEFVAR *WARN-ON-CHAR-CODE-USE* NIL "Warn if character codes are being used.") (IL-COPYDEF ATOM) (IL-COPYDEF BOUNDP) (IL-COPYDEF SET) (IL-DEFCONV LITATOM (X) (IL:* IL:|;;| "A more sophisticated code walker would tell us if this were being used as a test, and we could just expand to SYMBOLP then." ) (LET* ((XV (IF (SYMBOLP X) (CONVERT X) (MAKE-FAKE-SYMBOL (QUOTE ..X..)))) (BODY (IL:BQUOTE (AND ( SYMBOLP (IL:\\\, XV)) (IL:\\\, XV))))) (IF (SYMBOLP X) BODY (IL:BQUOTE (LET (((IL:\\\, XV) (IL:\\\, ( CONVERT X)))) (IL:\\\, BODY)))))) (IL-DEFCONV SETQQ (&REST PAIRS) (DO ((PAIRS PAIRS (REST (REST PAIRS))) (NEWPAIRS NIL)) ((ENDP PAIRS) ( IL:BQUOTE (SETQ (IL:\\\,@ (NREVERSE NEWPAIRS))))) (PUSH (CONVERT (FIRST PAIRS)) NEWPAIRS) (PUSH ( CONVERT (IL:BQUOTE (QUOTE (IL:\\\, (SECOND PAIRS))))) NEWPAIRS))) (IL-DEFCONV SETQ (&REST PAIRS) (DO ((PAIRS PAIRS (REST (REST PAIRS))) (NEWPAIRS NIL)) ((ENDP PAIRS) ( IL:BQUOTE (SETQ (IL:\\\,@ (NREVERSE NEWPAIRS))))) (PUSH (CONVERT (FIRST PAIRS)) NEWPAIRS) (PUSH ( IL:BQUOTE (IL:\\\, (CONVERT (SECOND PAIRS)))) NEWPAIRS))) (IL-DEFCONV PSETQ (&REST PAIRS) (DO ((PAIRS PAIRS (REST (REST PAIRS))) (NEWPAIRS NIL)) ((ENDP PAIRS) ( IL:BQUOTE (PSETQ (IL:\\\,@ (NREVERSE NEWPAIRS))))) (PUSH (CONVERT (FIRST PAIRS)) NEWPAIRS) (PUSH ( IL:BQUOTE (IL:\\\, (CONVERT (SECOND PAIRS)))) NEWPAIRS))) (IL-WARNINGFORM IL:GETTOPVAL) (IL-WARNINGFORM IL:SETTOPVAL) (IL-COPYDEF SET SETATOMVAL) (IL-DEFCONV GETATOMVAL (VAR) (IL:BQUOTE (SYMBOL-VALUE (IL:\\\, (CONVERT VAR))))) (IL-DEFCONV GETPROP (ATM PROP) (IF (QUOTED-SYMBOL-P ATM) (IL:BQUOTE (GET (IL:\\\, (CONVERT ATM)) ( IL:\\\, (CONVERT PROP)))) (IL:BQUOTE (AND (SYMBOLP (IL:\\\, (CONVERT ATM))) (GET (IL:\\\, (CONVERT ATM )) (IL:\\\, (CONVERT PROP))))))) (IL-DEFCONV PUTPROP (ATM PROP &OPTIONAL VAL) (IL:BQUOTE (SETF (GET (IL:\\\, (CONVERT ATM)) (IL:\\\, ( CONVERT PROP))) (IL:\\\, (CONVERT VAL))))) (IL-DEFCONV ADDPROP (SYM PROP VAL FRONTP) (LET ((SVAR (MAKE-FAKE-SYMBOL (QUOTE ..S..))) (PVAR ( MAKE-FAKE-SYMBOL (QUOTE ..P..))) (XVAR (MAKE-FAKE-SYMBOL (QUOTE ..X..)))) (CASE FRONTP ((T) (IL:BQUOTE (LET* (((IL:\\\, SVAR) (IL:\\\, SYM)) ((IL:\\\, PVAR) (IL:\\\, PROP)) ((IL:\\\, XVAR) (GET SVAR PVAR) )) (IF (IL:\\\, XVAR) (NCONC (IL:\\\, XVAR) (IL:\\\, VAL)) (SETF (GET (IL:\\\, SVAR) (IL:\\\, PVAR)) ( LIST (IL:\\\, VAL))))))) ((NIL) (IL:BQUOTE (PUSH (IL:\\\, VAL) (GET (IL:\\\, SYM) (IL:\\\, PROP))))) ( OTHERWISE (IL:BQUOTE (IF (IL:\\\, FRONTP) (PUSH (IL:\\\, VAL) (GET (IL:\\\, SYM) (IL:\\\, PROP))) ( LET* (((IL:\\\, SVAR) (IL:\\\, SYM)) ((IL:\\\, PVAR) (IL:\\\, PROP)) ((IL:\\\, XVAR) (GET (IL:\\\, SVAR) (IL:\\\, PVAR)))) (IF (IL:\\\, XVAR) (NCONC (IL:\\\, XVAR) (IL:\\\, VAL)) (SETF (GET (IL:\\\, SVAR) (IL:\\\, PVAR)) (LIST (IL:\\\, VAL))))))))))) (IL-DEFCONV REMPROP (ATM PROP) (IL:BQUOTE (PROGN (REMPROP (IL:\\\, (CONVERT ATM)) (IL:\\\, (CONVERT PROP))) NIL))) (IL-DEFCONV REMPROPLIST (ATM PROPS) (LET ((PVAR (MAKE-FAKE-SYMBOL (QUOTE .PROP.)))) (IL:BQUOTE (PROGN (DOLIST ((IL:\\\, PVAR) (IL:\\\, (CONVERT PROPS))) (REMPROP (IL:\\\, (CONVERT ATM)) (IL:\\\, PVAR))) NIL)))) (IL-DEFCONV CHANGEPROP (SYM PROP1 PROP2) (LET* ((SYMVAR-UNLETTED (OR (SYMBOLP SYM) (AND (CONSP SYM) ( EQ (CAR SYM) (QUOTE QUOTE)) (= (LENGTH SYM) 2)))) (SYMVAR (IF SYMVAR-UNLETTED (CONVERT SYM) ( MAKE-FAKE-SYMBOL (QUOTE ..SYM..)))) (BODY (IL:BQUOTE (SETF (GET (IL:\\\, SYMVAR) (IL:\\\, (CONVERT PROP2))) (GET (IL:\\\, SYMVAR) (IL:\\\, (CONVERT PROP1))))))) (IF SYMVAR-UNLETTED BODY (IL:BQUOTE (LET (((IL:\\\, SYMVAR) (IL:\\\, SYM))) (IL:\\\, BODY)))))) (IL-WARNINGFORM IL:PROPNAMES) (IL-WARNINGFORM IL:DEFLIST) (IL-COPYDEF SYMBOL-PLIST GETPROPLIST) (IL-COPYDEF GENTEMP GENSYM) (IL-DEFCONV MKATOM (X) (WARN "MKATOM translated for strings only.") (IL:BQUOTE (INTERN (IL:\\\, ( CONVERT X))))) (IL-DEFCONV L-CASE (THING &OPTIONAL FLG) (WARN "L-CASE translated for strings only") (CASE FLG ((T) ( IL:BQUOTE (STRING-CAPITALIZE (IL:\\\, (CONVERT THING))))) ((NIL) (IL:BQUOTE (STRING-DOWNCASE (IL:\\\, (CONVERT THING))))) (OTHERWISE (LET ((S (MAKE-FAKE-SYMBOL ".X."))) (IL:BQUOTE (LET (((IL:\\\, S) ( IL:\\\, (CONVERT THING)))) "L-CASE" (IF (IL:\\\, (CONVERT FLG)) (STRING-CAPITALIZE (IL:\\\, S)) ( STRING-DOWNCASE (IL:\\\, S))))))))) (IL-DEFCONV U-CASE (THING) (WARN "U-CASE translated for strings only") (IL:BQUOTE (STRING-UPCASE ( IL:\\\, (CONVERT THING))))) (IL-DEFCONV SETPROPLIST (ATM LST) (IL:BQUOTE (SETF (SYMBOL-PLIST (IL:\\\, (CONVERT ATM)) (IL:\\\, ( CONVERT LST)))))) (IL-DEFCONV CHARCODE (CHAR) (BLOCK CHARCODE (FLET ((CONVERT-CHAR (X) (COND ((TYPEP X (QUOTE (INTEGER 0 9))) (DIGIT-CHAR X)) ((EQL (LENGTH (STRING X)) 1) (CHAR (STRING X) 0)) ((AND (EQL (LENGTH (STRING X)) 2) (EQL (CHAR (STRING X) 0) #\^)) (CODE-CHAR (- (CHAR-CODE (CHAR-UPCASE (CHAR (STRING X) 1))) ( CHAR-CODE #\@)))) ((NAME-CHAR X)) (T (RETURN-FROM CHARCODE (LIST (CONVERT (QUOTE IL:CHARCODE)) ( CONVERT X))))))) (TYPECASE CHAR ((OR STRING SYMBOL (INTEGER 0 9)) (IL:BQUOTE (CHAR-CODE (IL:\\\, ( CONVERT-CHAR CHAR))))) (LIST (IL:BQUOTE (MAPCAR (FUNCTION CHAR-CODE) (QUOTE (IL:\\\, (MAPCAR (FUNCTION CONVERT-CHAR) CHAR)))))) (OTHERWISE (LIST (CONVERT (QUOTE CHARCODE)) (CONVERT CHAR))))))) (IL-DEFCONV NTHCHARCODE (X N &OPTIONAL FLG RDTBL) (COND ((OR FLG RDTBL) (WARN "Cannot translate NTHCHARCODE flg or rdtbl args") *CURRENT-EXPRESSION*) (T (IL:BQUOTE (CHAR ( SYMBOL-NAME (IL:\\\, (CONVERT X))) (IL:\\\, (CONVERT N))))))) (IL-DEFCONV CHARACTER (FORM) (IL:BQUOTE (CODE-CHAR (IL:\\\, (CONVERT FORM))))) (IL-DEFCONV CHCON1 (FORM) (IL:BQUOTE (CHAR-CODE (SVREF (SYMBOL-NAME (IL:\\\, (CONVERT FORM))) 0)))) (DEFUN EVAL-IF-POSSIBLE (X) (XCL:IGNORE-ERRORS (RETURN-FROM EVAL-IF-POSSIBLE (EVAL X))) X) (IL-DEFCONV SELCHARQ (KEY &REST CLAUSES &AUX X) (IL:BQUOTE (CASE (IL:\\\, (CONVERT KEY)) (IL:\\\,@ ( MAPCAR (FUNCTION (LAMBDA (CLAUSE &AUX X) (CONS (IF (CONSP (SETQ X (CAR CLAUSE))) (MAPCAR (FUNCTION ( LAMBDA (V) (EVAL-IF-POSSIBLE (CONVERT (IL:BQUOTE (IL:CHARCODE (IL:\\\, X))))))) X) (AND X ( EVAL-IF-POSSIBLE (CONVERT (IL:BQUOTE (IL:CHARCODE (IL:\\\, X))))))) (MAPCONVERT (CDR CLAUSE))))) ( BUTLAST CLAUSES))) (IL:\\\,@ (AND (SETQ X (CAR (LAST CLAUSES))) (IL:BQUOTE ((OTHERWISE (IL:\\\,@ (IF ( CONSP X) (CONVERT X) (LIST (CONVERT X)))))))))))) (IL-COPYCONV CHARACTER FCHARACTER) (IL-WARNINGFORM IL:PACK) (IL-WARNINGFORM IL:PACK*) (IL-WARNINGFORM IL:UNPACK) (IL-WARNINGFORM IL:DUNPACK) (IL-WARNINGFORM IL:MAPATOMS) (IL-WARNINGFORM IL:APROPOS) (IL-DEFCONV NLISTP (X) (IL:BQUOTE (NOT (LISTP (IL:\\\, (CONVERT X)))))) (IL-COPYDEF CONS) (IL-COPYDEF LISTP) (IL-COPYDEF CAR) (IL-COPYDEF CDR) (IL-COPYDEF CADR) (IL-COPYDEF CDAR) (IL-COPYDEF CDDR) (IL-COPYDEF CAAAR) (IL-COPYDEF CAADR) (IL-COPYDEF CADAR) (IL-COPYDEF CADDR) (IL-COPYDEF CDAAR) (IL-COPYDEF CDADR) (IL-COPYDEF CDDAR) (IL-COPYDEF CDDDR) (IL-COPYDEF CAAAAR) (IL-COPYDEF CAAADR) (IL-COPYDEF CAADAR) (IL-COPYDEF CAADDR) (IL-COPYDEF CADAAR) (IL-COPYDEF CDDDAR) (IL-COPYDEF CDDDDR) (IL-COPYDEF RPLACD) (IL-COPYDEF RPLACD FRPLACD) (IL-COPYDEF RPLACA) (IL-COPYDEF RPLACA FRPLACA) (IL-DEFCONV RPLNODE (X A D) (IL:BQUOTE (LET (($X$ (IL:\\\, (CONVERT X)))) (RPLACA $X$ (IL:\\\, ( CONVERT A))) (RPLACD $X$ (IL:\\\, (CONVERT D)))))) (IL-DEFCONV RPLNODE2 (X Y) (LET ((XVAR (MAKE-FAKE-SYMBOL ".X."))) (IL:BQUOTE (LET (((IL:\\\, XVAR) ( IL:\\\, (CONVERT X)))) (RPLACA (IL:\\\, XVAR) (CAR (IL:\\\, (CONVERT Y)))) (RPLACD (IL:\\\, XVAR) (CDR (IL:\\\, (CONVERT Y)))))))) (IL-DEFCONV FRPLNODE (X A D) (IL:BQUOTE (IL-RPLNODE (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT A)) (IL:\\\, (CONVERT D))))) (IL-DEFCONV FRPLNODE2 (X Y) (IL:BQUOTE (LET (($X$ (IL:\\\, (CONVERT X))) ($Y$ (IL:\\\, (CONVERT Y)))) (RPLACA $X$ (CAR $Y$)) (RPLACD $X$ (CDR $Y$)) $X$))) (IL-DEFCONV MKLIST (X) (IL:BQUOTE (LET (($X$ (IL:\\\, (CONVERT X)))) (IF (LISTP $X$) $X$ (LIST $X$)))) ) (IL-DEFCONV NCONC1 (LST X) (IL:BQUOTE (NCONC (IL:\\\, (CONVERT LST)) (LIST (IL:\\\, (CONVERT X)))))) (IL-COPYDEF LIST) (IL-COPYDEF LIST*) (IL-COPYDEF APPEND) (IL-COPYDEF NCONC) (IL-COPYDEF TAILP) (IL-COPYDEF LAST) (IL-COPYDEF LENGTH) (IL-COPYDEF LENGTH FLENGTH) (IL-COPYDEF SET-DIFFERENCE LDIFFERENCE) (IL-COPYDEF INTERSECTION) (IL-COPYDEF UNION) (IL-DEFCONV ATTACH (X L) (LET* ((CON-X (CONVERT X)) (CON-L (CONVERT L)) (XV (IF (SYMBOLP CON-X) CON-X (MAKE-FAKE-SYMBOL (QUOTE ..X..)))) (LV (IF (SYMBOLP CON-L) CON-L (MAKE-FAKE-SYMBOL (QUOTE ..L..)))) ( BODY (IL:BQUOTE (IF (IL:\\\, LV) (PROGN (SETF (CDR (IL:\\\, LV)) (CONS (CAR (IL:\\\, LV)) (CDR (IL:\\\, LV))) (CAR (IL:\\\, LV)) (IL:\\\, XV)) (IL:\\\, LV)) (CONS (IL:\\\, XV) NIL))))) (IF (AND (SYMBOLP CON-X) (SYMBOLP CON-L)) BODY (IL:BQUOTE (LET ((IL:\\\,@ (UNLESS (SYMBOLP CON-X) (IL:BQUOTE (((IL:\\\, XV) (IL:\\\, CON-X)))))) (IL:\\\,@ (UNLESS (SYMBOLP CON-L) (IL:BQUOTE (((IL:\\\, LV) (IL:\\\, CON-L))) )))) (IL:\\\, BODY)))))) (IL-DEFCONV LCONC (HEAD THING) (LET ((PV (MAKE-FAKE-SYMBOL ".P."))) (IF (NULL HEAD) (IL:BQUOTE (LET (( (IL:\\\, PV) (CONS (IL:\\\, (CONVERT THING)) NIL))) (CONS (IL:\\\, PV) (LAST (IL:\\\, PV))))) (IL:BQUOTE (LET (((IL:\\\, PV) (IL:\\\, (CONVERT HEAD)))) "LCONC" (IF (CONSP (IL:\\\, PV)) (SETF (CDDR (IL:\\\, PV)) (CONS (IL:\\\, (CONVERT THING)) NIL) (CDR (IL:\\\, PV)) (LAST (CDDR (IL:\\\, PV)))) (LET (((IL:\\\, PV) (CONS (IL:\\\, (CONVERT THING)) NIL))) (CONS (IL:\\\, PV) (LAST (IL:\\\, PV)))))))))) (IL-DEFCONV TCONC (HEAD THING) (LET ((PV (MAKE-FAKE-SYMBOL ".P."))) (IF (NULL HEAD) (IL:BQUOTE (LET (( (IL:\\\, PV) (CONS (IL:\\\, (CONVERT THING)) NIL))) (CONS (IL:\\\, PV) (IL:\\\, PV)))) (IL:BQUOTE (LET (((IL:\\\, PV) (IL:\\\, (CONVERT HEAD)))) "TCONC" (IF (CONSP (IL:\\\, PV)) (SETF (CDDR (IL:\\\, PV)) (CONS (IL:\\\, (CONVERT THING)) NIL) (CDR PV) (CDDR PV)) (LET (((IL:\\\, PV) (CONS (IL:\\\, (CONVERT THING)) NIL))) (CONS (IL:\\\, PV) (IL:\\\, PV))))))))) (IL-WARNINGFORM IL:DOCOLLECT) (IL-WARNINGFORM IL:ENDCOLLECT) (IL-WARNINGFORM IL:SCRATCHLIST) (IL-WARNINGFORM IL:ADDTOSCRATCHLIST) (IL-WARNINGFORM IL:COPYALL) (IL-WARNINGFORM IL:HCOPYALL) (IL-WARNINGFORM IL:NLEFT) (IL-WARNINGFORM IL:LASTN) (IL-WARNINGFORM IL:COUNT) (IL-WARNINGFORM IL:COUNTDOWN) (IL-WARNINGFORM IL:EQUALN) (IL-WARNINGFORM IL:LDIFF) (IL-WARNINGFORM IL:LSUBST) (IL-WARNINGFORM IL:SUBPAIR) (IL-COPYDEF COPY-LIST COPY) (IL-DEFCONV NTH (X N) (IL:BQUOTE (NTHCDR (1- (IL:\\\, (CONVERT N))) (IL:\\\, (CONVERT X))))) (IL-DEFCONV MEMB (X Y) (IL:BQUOTE (MEMBER (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y)) :TEST (FUNCTION EQ)))) (IL-DEFCONV FMEMB (X Y) (IL:BQUOTE (MEMBER (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y)) :TEST (FUNCTION EQ)))) (IL-DEFCONV MEMBER (X Y) (IL:BQUOTE (MEMBER (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y)) :TEST ( FUNCTION EQUAL)))) (IL-DEFCONV EQMEMB (X Y) (LET ((XV (MAKE-FAKE-SYMBOL (QUOTE .X.))) (YV (MAKE-FAKE-SYMBOL (QUOTE .Y.))) ) (IL:BQUOTE (LET (((IL:\\\, XV) (IL:\\\, (CONVERT X))) ((IL:\\\, YV) (IL:\\\, (CONVERT Y)))) "IL:EQMEMB" (OR (EQ (IL:\\\, XV) (IL:\\\, YV)) (MEMBER (IL:\\\, XV) (IL:\\\, YV) :TEST (FUNCTION EQ))) )))) (IL-DEFCONV SUBST (NEW OLD EXPR) (IL:BQUOTE (SUBST (IL:\\\, (CONVERT NEW)) (IL:\\\, (CONVERT OLD)) ( IL:\\\, (CONVERT EXPR)) :TEST (FUNCTION EQUAL)))) (IL-DEFCONV DSUBST (NEW OLD EXPR) (IL:BQUOTE (NSUBST (IL:\\\, (CONVERT NEW)) (IL:\\\, (CONVERT OLD)) ( IL:\\\, (CONVERT EXPR)) :TEST (FUNCTION EQUAL)))) (IL-DEFCONV SUBLIS (ALST EXPR FLG) (COND ((EQ FLG (QUOTE T)) (IL:BQUOTE (SUBLIS (IL:\\\, (CONVERT ALST )) (COPY-TREE (IL:\\\, (CONVERT EXPR)))))) ((NULL FLG) (IL:BQUOTE (SUBLIS (IL:\\\, (CONVERT ALST)) ( IL:\\\, (CONVERT EXPR))))) (T (IL:BQUOTE (SUBLIS (IL:\\\, (CONVERT ALST)) (IF (IL:\\\, (CONVERT FLG)) (COPY-TREE (IL:\\\, (CONVERT EXPR))) (IL:\\\, (CONVERT EXPR)))))))) (IL-DEFCONV DSUBLIS (ALST EXPR FLG) (COND ((EQ FLG (QUOTE T)) (IL:BQUOTE (NSUBLIS (IL:\\\, (CONVERT ALST)) (COPY-TREE (IL:\\\, (CONVERT EXPR)))))) ((NULL FLG) (IL:BQUOTE (NSUBLIS (IL:\\\, (CONVERT ALST) ) (IL:\\\, (CONVERT EXPR))))) (T (IL:BQUOTE (NSUBLIS (IL:\\\, (CONVERT ALST)) (IF (IL:\\\, (CONVERT FLG)) (COPY-TREE (IL:\\\, (CONVERT EXPR))) (IL:\\\, (CONVERT EXPR)))))))) (IL-DEFCONV ASSOC (KEY ALST) (IL:BQUOTE (ASSOC (IL:\\\, (CONVERT KEY)) (IL:\\\, (CONVERT ALST)) :TEST (FUNCTION EQ)))) (IL-DEFCONV SASSOC (KEY ALST) (IL:BQUOTE (ASSOC (IL:\\\, (CONVERT KEY)) (IL:\\\, (CONVERT ALST)) :TEST (FUNCTION EQUAL)))) (IL-DEFCONV PUTASSOC (KEY VAL ALST) (LET ((AVAR (MAKE-FAKE-SYMBOL (QUOTE .ALIST.))) (KVAR ( MAKE-FAKE-SYMBOL (QUOTE .KEY.))) (CVAR (MAKE-FAKE-SYMBOL (QUOTE .ASSN.)))) (IL:BQUOTE (LET* (((IL:\\\, KVAR) (IL:\\\, (CONVERT KEY))) ((IL:\\\, CVAR) (ASSOC (IL:\\\, KVAR) (IL:\\\, AVAR)))) "IL:PUTASSOC" (IF (IL:\\\, CVAR) (SETF (CDR (IL:\\\, CVAR)) (IL:\\\, (CONVERT VAL))) (IF (CONSP (IL:\\\, AVAR)) ( NCONC (IL:\\\, AVAR) (CONS (CONS (IL:\\\, KVAR) (IL:\\\, (CONVERT VAL))) NIL)))))))) (IL-COPYCONV NTH FNTH) (IL-COPYCONV LAST FLAST) (IL-COPYCONV MEMB FMEMB) (IL-COPYCONV ASSOC FASSOC) (IL-COPYDEF GETF LISTGET) (IL-DEFCONV LISTPUT (LST PROP VAL) (IL:BQUOTE (SETF (GETF (IL:\\\, (CONVERT LST)) (IL:\\\, (CONVERT PROP))) (IL:\\\, (CONVERT VAL))))) (IL-DEFCONV LISTGET1 (LST PROP) (IL:BQUOTE (SECOND (MEMBER (IL:\\\, (CONVERT PROP)) (IL:\\\, (CONVERT LST)) :TEST (FUNCTION EQ))))) (IL-DEFCONV MERGE (A B COMPAREFN) (IL:BQUOTE (MERGE (QUOTE LIST) (IL:\\\, (CONVERT A)) (IL:\\\, ( CONVERT B)) (IL:\\\, (CONVERT COMPAREFN))))) (IL-WARNINGFORM IL:LISTPUT1) (IL-WARNINGFORM IL:ALPHORDER) (IL-WARNINGFORM IL:UALPHORDER) (IL-WARNINGFORM IL:COMPARELISTS) (IL-DEFCONV REMOVE (X L) (IL:BQUOTE (REMOVE (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT L)) :TEST ( FUNCTION EQUAL)))) (IL-DEFCONV DREMOVE (X L) (IL:BQUOTE (DELETE (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT L)) :TEST ( FUNCTION EQ)))) (IL-DEFCONV REVERSE (L) (LET ((LVAR (MAKE-FAKE-SYMBOL ".L."))) (IL:BQUOTE (LET (((IL:\\\, LVAR) (IL:\\\, (CONVERT L)))) (IF (LISTP (IL:\\\, LVAR)) (REVERSE (IL:\\\, LVAR)) (IL:\\\, LVAR)))))) (IL-DEFCONV DREVERSE (L) (IL:BQUOTE (IF (LISTP (IL:\\\, L)) (NREVERSE (IL:\\\, L)) (IL:\\\, L)))) (IL-DEFCONV NEGATE (X) (IL:BQUOTE (NOT (IL:\\\, (CONVERT X))))) (IL-COPYDEF STRINGP) (IL-DEFCONV STREQUAL (X Y) (LET* ((XVARP (NOT (OR (STRINGP X) (SYMBOLP X)))) (YVARP (NOT (OR (STRINGP Y) (SYMBOLP Y)))) (XV (IF XVARP (MAKE-FAKE-SYMBOL "$X") (CONVERT X))) (YV (IF YVARP (MAKE-FAKE-SYMBOL "$Y") (CONVERT Y)))) (IF (OR XVARP YVARP) (IL:BQUOTE (LET ((IL:\\\,@ (AND XVARP (IL:BQUOTE (((IL:\\\, XV) (IL:\\\, (CONVERT X))))))) (IL:\\\,@ (AND YVARP (IL:BQUOTE (((IL:\\\, YV) (IL:\\\, (CONVERT Y))))) ))) "IL:STREQUAL" (AND (IL:\\\,@ (IF (NOT (STRINGP X)) (IL:BQUOTE ((STRINGP (IL:\\\, XV)))))) (IL:\\\,@ (IF (NOT (STRINGP Y)) (IL:BQUOTE ((STRINGP (IL:\\\, YV)))))) (STRING= (IL:\\\, XV) (IL:\\\, YV))))) ( IL:BQUOTE (STRING= (IL:\\\, XV) (IL:\\\, YV)))))) (IL-DEFCONV STRING-EQUAL (X Y) (LET* ((XVARP (NOT (OR (STRINGP X) (SYMBOLP X)))) (YVARP (NOT (OR ( STRINGP Y) (SYMBOLP Y)))) (XV (IF XVARP (MAKE-FAKE-SYMBOL "$X") (CONVERT X))) (YV (IF YVARP ( MAKE-FAKE-SYMBOL "$Y") (CONVERT Y)))) (IF (OR XVARP YVARP) (IL:BQUOTE (LET ((IL:\\\,@ (AND XVARP ( IL:BQUOTE (((IL:\\\, XV) (IL:\\\, (CONVERT X))))))) (IL:\\\,@ (AND YVARP (IL:BQUOTE (((IL:\\\, YV) ( IL:\\\, (CONVERT Y)))))))) "IL:STREQUAL" (AND (IL:\\\,@ (IF (NOT (STRINGP X)) (IL:BQUOTE ((STRINGP ( IL:\\\, XV)))))) (IL:\\\,@ (IF (NOT (STRINGP Y)) (IL:BQUOTE ((STRINGP (IL:\\\, YV)))))) (STRING= ( IL:\\\, XV) (IL:\\\, YV))))) (IL:BQUOTE (STRING-EQUAL (IL:\\\, XV) (IL:\\\, YV)))))) (IL-DEFCONV NCHARS (THING &OPTIONAL FLG) (DECLARE (IGNORE FLG)) (IL:* IL:|;;| "Assume it will be a string or symbol; most common case by far.") (IL:BQUOTE (LENGTH (STRING (IL:\\\, (CONVERT THING)))))) (DEFUN ALLOCSTRING (N &OPTIONAL INITCHAR OLD FATFLG) (COND (OLD (WARN "Cannot convert ALLOCSTRING old argument") *CURRENT-EXPRESSION*) (T (IL:BQUOTE (MAKE-STRING (IL:\\\, ( CONVERT N)) (IL:\\\,@ (IF INITCHAR (LIST :INITIAL-ELEMENT (CONVERT INITCHAR)) NIL))))))) (IL-DEFCONV MKSTRING (X &OPTIONAL FLG RDTBL) (IL:BQUOTE (WRITE-TO-STRING (IL:\\\, (CONVERT X)) :ESCAPE (IL:\\\, (CONVERT FLG))))) (IL-DEFCONV CONCAT (&REST XX) (IL:BQUOTE (CONCATENATE (QUOTE STRING) (IL:\\\,@ (MAPCONVERT XX))))) (IL-DEFCONV CONCATLIST (L) (IL:BQUOTE (APPLY (FUNCTION CONCATENATE) (QUOTE STRING) (MAPCAR (FUNCTION ( LAMBDA (X) (PRINC-TO-STRING X))) (IL:\\\, (CONVERT L)))))) (IL-DEFCONV RPLSTRING (X N Y) (IL:BQUOTE (REPLACE (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y)) :START1 (IL:\\\, (CONVERT N))))) (IL-DEFCONV RPLCHARCODE (X N CODE) (IL:BQUOTE (SETF (CHAR (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT N))) (CODE-CHAR (IL:\\\, (CONVERT CODE)))))) (IL-DEFCONV STRPOS (PAT STRING &OPTIONAL START SKIP ANCHOR TAIL CASEARRAY BACKWARDSFLG) (WHEN CASEARRAY (WARN "CASEARRAY arg to STRPOS not translated.")) (WHEN ANCHOR (WARN "ANCHOR arg to STRPOS not translated.")) (WHEN TAIL (WARN "TAIL arg to STRPOS not translated.")) (WHEN SKIP (WARN "SKIP arg to STRPOS not translated.")) (IL:BQUOTE (SEARCH (IL:\\\, (CONVERT PAT)) (IL:\\\, (CONVERT STRING)) (IL:\\\,@ (AND START (IL:BQUOTE (:START2 (1- (IL:\\\, (CONVERT START))))))) (IL:\\\,@ (AND BACKWARDSFLG (IL:BQUOTE (:FROM-END-P (IL:\\\, (CONVERT BACKWARDSFLG))))))))) (IL-DEFCONV SUBSTRING (X N &OPTIONAL M OLDPTR) (IL:BQUOTE (SUBSEQ (IL:\\\, (CONVERT X)) (IL:\\\, ( CONVERT N)) (IL:\\\, (CONVERT M))))) (IL-WARNINGFORM IL:GNC) (IL-WARNINGFORM IL:GLC) (IL-DEFCONV MAPHASH (HARRAY MAPHFN) (IF (AND (CONSP MAPHFN) (EQ (CAR MAPHFN) (QUOTE FUNCTION)) (CONSP (SECOND MAPHFN)) (EQ (CAR (SECOND MAPHFN)) (QUOTE LAMBDA))) (IL:BQUOTE (MAPHASH (FUNCTION (LAMBDA (( IL:\\\, (CONVERT (SECOND (SECOND (SECOND MAPHFN))))) (IL:\\\, (CONVERT (FIRST (SECOND (SECOND MAPHFN)) )))) IL:\\\, (MAPCONVERT (CDDR (SECOND MAPHFN))))) (IL:\\\, (CONVERT HARRAY)))) (IF (AND (CONSP MAPHFN ) (EQ (CAR MAPHFN) (QUOTE LAMBDA))) (IL:BQUOTE (MAPHASH (FUNCTION (LAMBDA ((IL:\\\, (CONVERT (SECOND ( SECOND MAPHFN)))) (IL:\\\, (CONVERT (FIRST (SECOND MAPHFN))))) IL:\\\, (MAPCONVERT (CDDR MAPHFN)))))) (IL:BQUOTE (MAPHASH (FUNCTION (LAMBDA (KEY VAL) (FUNCALL (IL:\\\, (CONVERT MAPHFN)) VAL KEY))) (IL:\\\, (CONVERT HARRAY))))))) (IL-DEFCONV GETHASH (KEY &OPTIONAL TABLE) (IL:BQUOTE ((IL:\\\, (IF TABLE (QUOTE GETHASH) (CONVERT ( QUOTE GETHASH)))) (IL:\\\, (CONVERT KEY)) (IL:\\\,@ (AND TABLE (LIST (CONVERT TABLE))))))) (IL-DEFCONV PUTHASH (KEY VAL &OPTIONAL TBL) (IF TBL (IL:BQUOTE (SETF (GETHASH (IL:\\\, (CONVERT KEY)) (IL:\\\, (CONVERT TBL))) (IL:\\\, (CONVERT VAL)))) (LIST (CONVERT (QUOTE PUTHASH)) (CONVERT VAL) ( CONVERT KEY)))) (IL-DEFCONV SMALLP (X) (DECLARE (IGNORE X)) NIL) (IL-DEFCONV FIXP (X) (IL:BQUOTE (INTEGERP (IL:\\\, (CONVERT X))))) (IL-COPYDEF FLOATP) (IL-COPYDEF NUMBERP) (IL-COPYDEF EQUALP EQP) (IL-DEFCONV PLUS (&REST ARGS) (IL:BQUOTE (+ (IL:\\\,@ (MAPCONVERT ARGS))))) (IL-DEFCONV MINUS (X) (IL:BQUOTE (- (IL:\\\, (CONVERT X))))) (IL-DEFCONV DIFFERENCE (X Y) (IL:BQUOTE (- (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) (IL-DEFCONV TIMES (&REST ARGS) (IL:BQUOTE (* (IL:\\\,@ (MAPCONVERT ARGS))))) (IL-DEFCONV GREATERP (X Y) (IL:BQUOTE (> (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) (IL-DEFCONV LESSP (X Y) (IL:BQUOTE (< (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) (IL-DEFCONV GEQ (X Y) (IL:BQUOTE (>= (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) (IL-DEFCONV LEQ (X Y) (IL:BQUOTE (<= (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) (IL-COPYDEF ZEROP) (IL-COPYDEF MINUSP) (IL-COPYDEF MIN) (IL-COPYDEF MAX) (IL-COPYDEF ABS) (IL-DEFCONV IPLUS (&REST ARGS) (IL:BQUOTE (+ (IL:\\\,@ (MAPCONVERT ARGS))))) (IL-DEFCONV IMINUS (&REST ARGS) (IL:BQUOTE (- (IL:\\\,@ (MAPCONVERT ARGS))))) (IL-DEFCONV IDIFFERENCE (X Y) (IL:BQUOTE (- (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) (IL-DEFCONV ADD1 (X) (IL:BQUOTE (1+ (IL:\\\, (CONVERT X))))) (IL-DEFCONV SUB1 (X) (IL:BQUOTE (1- (IL:\\\, (CONVERT X))))) (IL-DEFCONV ITIMES (&REST ARGS) (IL:BQUOTE (* (IL:\\\,@ (MAPCONVERT ARGS))))) (IL-DEFCONV IQUOTIENT (X Y) (IL:BQUOTE (TRUNCATE (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) (IL-DEFCONV IREMAINDER (X Y) (IL:BQUOTE (REM (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) (IL-DEFCONV IMOD (X Y) (IL:BQUOTE (MOD (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) (IL-DEFCONV IGREATERP (X Y) (IL:BQUOTE (> (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) (IL-DEFCONV ILESSP (X Y) (IL:BQUOTE (< (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) (IL-DEFCONV IGEQ (X Y) (IL:BQUOTE (>= (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) (IL-DEFCONV ILEQ (X Y) (IL:BQUOTE (<= (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) (IL-DEFCONV IMIN (&REST ARGS) (IL:BQUOTE (MIN (IL:\\\,@ (MAPCONVERT ARGS))))) (IL-DEFCONV IMAX (&REST ARGS) (IL:BQUOTE (MAX (IL:\\\,@ (MAPCONVERT ARGS))))) (IL-DEFCONV IEQP (X Y) (IL:BQUOTE (EQL (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y))))) (IL-DEFCONV FIX (N) (IL:BQUOTE (TRUNCATE (IL:\\\, (CONVERT N))))) (IL-DEFCONV FIXR (N) (IL:BQUOTE (ROUND (IL:\\\, (CONVERT N))))) (IL-DEFCONV RSH (X N) (IL:BQUOTE (ASH (IL:\\\, (CONVERT X)) (IL:\\\, (SIMP-MINUS (CONVERT N)))))) (IL-DEFCONV POWEROFTWOP (X) (IL:BQUOTE (= (LOGCOUNT (IL:\\\, (CONVERT X))) 1))) (IL-DEFCONV EVENP (X &OPTIONAL (Y 2)) (IL:BQUOTE (ZEROP (MOD (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y )))))) (IL-DEFCONV ODDP (X &OPTIONAL (Y 2)) (IL:BQUOTE (NOT (ZEROP (MOD (IL:\\\, (CONVERT X)) (IL:\\\, ( CONVERT Y))))))) (IL-DEFCONV BITTEST (N MASK) (IL:BQUOTE (NOT (= 0 (LOGAND (IL:\\\, (CONVERT N)) (IL:\\\, (CONVERT MASK ))))))) (IL-DEFCONV BITCLEAR (N MASK) (IL:BQUOTE (LOGAND (IL:\\\, (CONVERT N)) (LOGNOT (IL:\\\, (CONVERT MASK) ))))) (IL-COPYDEF GCD) (IL-COPYDEF LOGAND) (IL-COPYDEF LOGIOR LOGOR) (IL-COPYDEF ASH LSH) (IL-COPYDEF INTEGER-LENGTH INTEGERLENGTH) (IL-COPYDEF LOGNOT) (IL-COPYDEF LOGIOR BITSET) (IL-DEFCONV MASK.1\'S (POSITION SIZE) (IL:BQUOTE (ASH (1- (EXPT 2 (IL:\\\, (CONVERT SIZE)))) (IL:\\\, (CONVERT POSITION))))) (IL-DEFCONV MASK.0\'S (POSITION SIZE) (IL:BQUOTE (LOGNOT (ASH (1- (EXPT 2 (IL:\\\, (CONVERT SIZE)))) ( IL:\\\, (CONVERT POSITION)))))) (IL-DEFCONV LOADBYTE (N POS SIZE) (IL:BQUOTE (LDB (BYTE (IL:\\\, (CONVERT SIZE)) (IL:\\\, (CONVERT POS ))) (IL:\\\, (CONVERT N))))) (IL-DEFCONV DEPOSITBYTE (N POS SIZE VAL) (IL:BQUOTE (DPB (IL:\\\, (CONVERT VAL)) (BYTE (IL:\\\, ( CONVERT SIZE)) (IL:\\\, (CONVERT POS))) (IL:\\\, (CONVERT N))))) (IL-COPYDEF BYTE) (IL-COPYDEF BYTE-SIZE BYTESIZE) (IL-COPYDEF BYTE-POSITION BYTEPOSITION) (IL-COPYDEF LDB) (IL-COPYDEF DPB) (IL-WARNINGFORM IL:ROT) (IL-DEFCONV |push| (PLACE VALUE) (IL:BQUOTE (PUSH (IL:\\\, (CONVERT VALUE)) (IL:\\\, (CONVERT PLACE))) )) (IL-DEFCONV |add| (PLACE &OPTIONAL INCREMENT &REST MORE-INCREMENTS) (COND (MORE-INCREMENTS (IL:BQUOTE (INCF (IL:\\\, (CONVERT PLACE)) (+ (IL:\\\, (CONVERT INCREMENT)) (IL:\\\,@ (MAPCONVERT MORE-INCREMENTS )))))) (INCREMENT (IL:BQUOTE (INCF (IL:\\\, (CONVERT PLACE)) (IL:\\\, (CONVERT INCREMENT))))) (T ( CONVERT PLACE)))) (IL-DEFCONV |change| (PLACE FORM) (COND ((OR (ATOM PLACE) (AND (= (LENGTH PLACE) 2) (ATOM (SECOND PLACE)))) (IL:BQUOTE (SETF (IL:\\\, (CONVERT PLACE)) (IL:\\\, (CONVERT (IL:SUBPAIR (QUOTE IL:DATUM) PLACE FORM)))))) ((= (LENGTH PLACE) 2) (LET ((NEW-PLACE (LIST (FIRST PLACE) (QUOTE $PLACE-ARG$)))) ( IL:BQUOTE (LET (($PLACE-ARG$ (IL:\\\, (SECOND PLACE)))) (SETF (IL:\\\, (CONVERT NEW-PLACE)) (IL:\\\, ( CONVERT (IL:SUBPAIR (QUOTE IL:DATUM) NEW-PLACE FORM)))))))) (T (IL:BQUOTE (SETF (IL:\\\, (CONVERT PLACE)) (IL:\\\, (CONVERT (IL:SUBPAIR (QUOTE IL:DATUM) PLACE FORM)))))))) (IL-DEFCONV |pushnew| (PLACE THING) (IL:BQUOTE (PUSHNEW (IL:\\\, (CONVERT THING)) (IL:\\\, (CONVERT PLACE)) :TEST (QUOTE EQ)))) (IL-DEFCONV |pushlist| (PLACE &REST LISTS) (LET ((NEWPLACE (CONVERT PLACE))) (IL:BQUOTE (SETF (IL:\\\, NEWPLACE) (APPEND (IL:\\\,@ (MAPCONVERT LISTS)) (IL:\\\, NEWPLACE)))))) (IL-DEFCONV |swap| (PLACE1 PLACE2) (IL:BQUOTE (ROTATEF (IL:\\\, (CONVERT PLACE1)) (IL:\\\, (CONVERT PLACE2))))) (IL-COPYCONV |push| PUSH) (IL-COPYCONV |add| ADD) (IL-COPYCONV |change| CHANGE) (IL-COPYCONV |pushnew| PUSHNEW) (IL-COPYCONV |pushlist| PUSHLIST) (IL-COPYCONV |swap| SWAP) (IL-COPYDEF POP) (IL-COPYDEF POP |pop|) (IL-COPYDEF EQ) (IL-COPYDEF NULL) (IL-COPYDEF NOT) (IL-COPYDEF EQUAL) (IL-COPYDEF AND) (IL-COPYDEF OR) (IL-DEFCONV NEQ (X Y) (IL:BQUOTE (NOT (EQ (IL:\\\, (CONVERT X)) (IL:\\\, (CONVERT Y)))))) (IL-DEFCONV COND (&REST CLAUSES) (IL:BQUOTE (COND (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (CLAUSE) ( MAPCONVERT CLAUSE))) CLAUSES))))) (IL-DEFCONV |if| (&REST ARGS &AUX (FORM (LIST (QUOTE COND)))) (IL:* IL:|;;| "don't use '(cond) because nreverse will smash it") (DO ((CLAUSE (LIST (CONVERT (POP ARGS)))) ARG) (( ENDP ARGS) (WHEN CLAUSE (PUSH (NREVERSE CLAUSE) FORM))) (CASE (SETQ ARG (POP ARGS)) ((IL:|then| IL:THEN )) ((IL:ELSE IL:|else|) (PUSH (NREVERSE CLAUSE) FORM) (SETQ CLAUSE (LIST (QUOTE T)))) (IL:* IL:|;;| "don't use '(t) because nreverse will smash it") ((IL:ELSEIF IL:|elseif|) (PUSH (NREVERSE CLAUSE) FORM ) (SETQ CLAUSE (LIST (CONVERT (POP ARGS))))) (OTHERWISE (PUSH (CONVERT ARG) CLAUSE)))) (NREVERSE FORM) ) (IL-COPYCONV |if| IF) (IL-DEFCONV SELECTQ (X &REST CLAUSES) (IL:BQUOTE (CASE (IL:\\\, (CONVERT X)) (IL:\\\,@ (MAPCAR ( FUNCTION (LAMBDA (CLAUSE) (IL:BQUOTE ((IL:\\\, (QUOTE-TREE (FIRST CLAUSE))) (IL:\\\,@ (MAPCONVERT ( REST CLAUSE))))))) (BUTLAST CLAUSES))) (OTHERWISE (IL:\\\,@ (MAPCONVERT (LAST CLAUSES))))))) (IL-DEFCONV SELECTC (X &REST CLAUSES) (LET* ((DATUM (IF (SYMBOLP X) (CONVERT X) (GENTEMP))) (MAINBODY (IL:BQUOTE (COND (IL:\\\,@ (MAP (QUOTE LIST) (FUNCTION (LAMBDA (CLAUSE) (IL:BQUOTE ((EQL (IL:\\\, DATUM) (IL:\\\, (CONVERT (FIRST CLAUSE)))) (IL:\\\,@ (MAPCONVERT (REST CLAUSE))))))) (BUTLAST CLAUSES) )) (T (IL:\\\,@ (MAPCONVERT (LAST CLAUSES)))))))) (IF (SYMBOLP X) MAINBODY (IL:BQUOTE (LET (((IL:\\\, DATUM) (IL:\\\, (CONVERT X)))) (IL:\\\, MAINBODY)))))) (IL-DEFCONV CASE (X &REST CLAUSES) (IL:BQUOTE (CASE (IL:\\\, (CONVERT X)) (IL:\\\,@ (MAPCAR (FUNCTION (LAMBDA (CLAUSE) (IL:BQUOTE ((IL:\\\, (QUOTE-TREE (FIRST CLAUSE))) (IL:\\\,@ (MAPCONVERT (REST CLAUSE) )))))) CLAUSES))))) (IL-COPYDEF PROG1) (IL-COPYDEF PROG2) (IL-COPYDEF PROGN) (IL-COPYDEF RETURN) (IL-COPYDEF RETURN-FROM RETFROM) (IL-DEFCONV GO (TAG) (IL:BQUOTE (GO (IL:\\\, (CONVERT TAG))))) (IL-DEFCONV PROG (VARLST &REST FORMS) (DECLARE (SPECIAL *LOCALS*)) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST) (IL:BQUOTE (PROG (IL:\\\, NEW-VARLST) (IL:\\\,@ (LET ((*LOCALS* ( APPEND VARNAMES *LOCALS*))) (MAPCONVERT FORMS))))))) (IL-DEFCONV LET (VARLST &REST FORMS) (DECLARE (SPECIAL *LOCALS*)) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST) (IL:BQUOTE (LET (IL:\\\, NEW-VARLST) (IL:\\\,@ (LET ((*LOCALS* ( APPEND VARNAMES *LOCALS*))) (MAPCONVERT FORMS))))))) (IL-DEFCONV LET* (VARLST &REST FORMS) (DECLARE (SPECIAL *LOCALS*)) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST :SEQUENTIAL T) (IL:BQUOTE (LET* (IL:\\\, NEW-VARLST) (IL:\\\,@ (LET ( (*LOCALS* (APPEND VARNAMES *LOCALS*))) (MAPCONVERT FORMS))))))) (IL-DEFCONV PROG* (VARLST &REST FORMS) (DECLARE (SPECIAL *LOCALS*)) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST :SEQUENTIAL T) (IL:BQUOTE (PROG* (IL:\\\, NEW-VARLST) (IL:\\\,@ (LET ((*LOCALS* (APPEND VARNAMES *LOCALS*))) (MAPCONVERT FORMS))))))) (DEFUN CONVERT-DO (BINDINGS END-CLAUSES &REST BODY) (DECLARE (SPECIAL *LOCALS*)) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST BINDINGS) (LET ((*LOCALS* (APPEND VARNAMES *LOCALS*))) (IL:BQUOTE (DO (IL:\\\, NEW-VARLST) (IL:\\\,@ (MAPCONVERT END-CLAUSES)) (IL:\\\,@ (MAPCONVERT BODY))))))) (DEFUN CONVERT-DO* (BINDINGS END-CLAUSES &REST BODY) (DECLARE (SPECIAL *LOCALS*)) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST BINDINGS) (LET ((*LOCALS* (APPEND VARNAMES *LOCALS*))) (IL:BQUOTE (DO* (IL:\\\, NEW-VARLST) (IL:\\\,@ (MAPCONVERT END-CLAUSES)) (IL:\\\,@ (MAPCONVERT BODY))))))) (SETF (GET (QUOTE DO) (QUOTE CONVERT-FORM)) (QUOTE CONVERT-DO) (GET (QUOTE DO*) (QUOTE CONVERT-FORM)) (QUOTE CONVERT-DO*)) (DEFPARAMETER *ITERATION-CONVERSION-TABLE* (QUOTE ((IL:|for| ((:EXPR-OR-ASSIGNMENT ((IL:|in| :EXPR (( IL:|by| FILTER-LIST-BY) (T . T))) (IL:|on| :EXPR ((IL:|by| FILTER-LIST-BY) (T . T))) (IL:|from| :EXPR ((IL:|to| :EXPR ((IL:|by| :EXPR T) (T . T))) (T . T))) (IL:|to| :EXPR ((IL:|by| :EXPR T) (T . T)) (T . T)) (IL:|by| (THEN) :EXPR T) (IL:|instring| FILTER-INSTRING))))) (IL:|as| ((:EXPR-OR-ASSIGNMENT (( IL:|in| :EXPR ((IL:|by| FILTER-LIST-BY) (T . T))) (IL:|on| :EXPR ((IL:|by| FILTER-LIST-BY) (T . T))) ( IL:|from| :EXPR ((IL:|to| :EXPR ((IL:|by| :EXPR T) (T . T))) (T . T))) (IL:|to| :EXPR ((IL:|by| :EXPR T) (T . T)) (T . T)) (IL:|by| :EXPR T) (IL:|instring| FILTER-INSTRING))))) (IL:|to| (REPEAT) :EXPR (( IL:|by| :EXPR T) (T . T))) (IL:|bind| FILTER-BIND) (IL:|collect| FILTER-DO) (IL:|repeatwhile| FILTER-REPEATWHILE/UNTIL) (IL:|repeatuntil| FILTER-REPEATWHILE/UNTIL) (IL:|while| :EXPR T) (IL:|until| :EXPR T) (IL:|when| :EXPR T) (IL:|unless| :EXPR T) (IL:|first| (INITIALLY) FILTER-DO) (IL:|finally| FILTER-DO) (IL:|join| (NCONC) FILTER-DO) (IL:|sum| :EXPR T) (IL:|count| :EXPR T) (IL:|always| :EXPR T) (IL:|never| :EXPR T) (IL:|thereis| :EXPR T) (IL:|largest| (MAXIMIZE) :EXPR T) (IL:|smallest| ( MINIMIZE) :EXPR T) (IL:|do| FILTER-DO)))) (DEFUN CONVERT-ITERATION-STATEMENT (INITIAL-OPER REST-OF-FORM &AUX (REST REST-OF-FORM) (INITIAL INITIAL-OPER) SO-FAR) (IL:* IL:|;;| "Yeah, this is sort of ugly. So is CLISPIFY.") (LABELS ((LOSE ( FMT-STRING &REST FMT-ARGS) (WARN "Couldn't translate I.S. form because ~?" FMT-STRING FMT-ARGS) (LET ( (FORM (CONS INITIAL-OPER REST-OF-FORM))) (RETURN-FROM CONVERT-ITERATION-STATEMENT FORM))) (NEXT-STATE (KEY CURRENT-LEVEL) (LET* (CLISPWORD (KEY-IS-IS-OPER-P (AND (SYMBOLP KEY) (EQ (CAR (SETQ CLISPWORD ( GET KEY (QUOTE IL:CLISPWORD)))) (QUOTE IL:FORWORD)))) (ASSOC-KEY (IF KEY-IS-IS-OPER-P (CDR CLISPWORD) KEY)) (FOUND (OR (ASSOC ASSOC-KEY CURRENT-LEVEL :TEST (FUNCTION (LAMBDA (A B) (IF (AND (SYMBOLP A) ( SYMBOLP B)) (STRING-EQUAL A B) (EQ A B))))) (AND (NOT KEY-IS-IS-OPER-P) (OR (ASSOC (QUOTE :EXPR) CURRENT-LEVEL) (ASSOC (QUOTE :EXPR-OR-ASSIGNMENT) CURRENT-LEVEL))) (ASSOC (QUOTE T) CURRENT-LEVEL))) ( CURRENT-ENTRY (CDR FOUND))) (IF CURRENT-ENTRY (COND ((AND (EQ (CAR FOUND) :EXPR-OR-ASSIGNMENT) (CONSP KEY) (EQ (SECOND KEY) (QUOTE IL:_))) (SETQ SO-FAR (LIST* (CONVERT (THIRD KEY)) (MAKE-FAKE-SYMBOL "=") (CONVERT (FIRST KEY)) SO-FAR))) ((MEMBER (CAR FOUND) (QUOTE (T :EXPR :EXPR-OR-ASSIGNMENT))) (PUSH (IF (EQ CURRENT-ENTRY (QUOTE T)) NIL (CONVERT KEY)) SO-FAR)) (T (PUSH (MAKE-FAKE-SYMBOL (STRING-UPCASE ( STRING KEY))) SO-FAR))) (LOSE "Key ~a not expected" KEY)) (LOOP (COND ((EQ CURRENT-ENTRY (QUOTE T)) ( IL:* IL:\; "(mumble . T)") (PUSH KEY REST) (IL:* IL:\; "means punt this token.") (POP SO-FAR) ( RETURN-FROM NEXT-STATE)) ((EQ (CAR CURRENT-ENTRY) (QUOTE T)) (RETURN-FROM NEXT-STATE)) ((CONSP (CAR CURRENT-ENTRY)) (IF (CONSP (CAAR CURRENT-ENTRY)) (IL:* IL:|;;| "Assoc list...") (LET ((NEXT-KEY (POP REST))) (NEXT-STATE NEXT-KEY (CAR CURRENT-ENTRY)) (RETURN-FROM NEXT-STATE)) (IL:* IL:|;;| "substitution...") (SETF (CAR SO-FAR) (MAKE-FAKE-SYMBOL (CAAR CURRENT-ENTRY))))) ((MEMBER (CAR CURRENT-ENTRY) (QUOTE (:EXPR-OR-ASSIGNMENT :EXPR))) (IF (AND (SYMBOLP (CAR REST)) (EQ (CAR (GET (CAR REST) (QUOTE IL:CLISPWORD))) (QUOTE IL:FORWORD))) (LOSE "~a where expression expected" (CAR REST)) ( PUSH (CONVERT (COPY-TREE (POP REST))) SO-FAR))) ((NULL (CDR CURRENT-ENTRY)) (MULTIPLE-VALUE-SETQ ( SO-FAR REST) (FUNCALL (CAR CURRENT-ENTRY) SO-FAR REST (FUNCTION LOSE))) (RETURN-FROM NEXT-STATE)) (T ( IF (EQ (CAR CURRENT-ENTRY) (CAR REST)) (PUSH (CONVERT (COPY-TREE (POP REST))) SO-FAR) (LOSE "Expected ~a" (CAR CURRENT-ENTRY))))) (POP CURRENT-ENTRY))))) (LOOP (NEXT-STATE INITIAL *ITERATION-CONVERSION-TABLE*) (WHEN (NULL REST) (RETURN (CONS (MAKE-FAKE-SYMBOL (QUOTE LOOP)) ( NREVERSE SO-FAR)))) (SETQ INITIAL (POP REST))))) (DEFUN FILTER-NUMERIC-BY (SO-FAR REST)) (DEFUN FILTER-LIST-BY (SO-FAR REST) (LET ((STEP-FORM (POP REST)) (VAR (FOURTH SO-FAR)) (OPERAND ( SECOND SO-FAR))) (IF (AND (CONSP STEP-FORM) (= (LENGTH STEP-FORM) 2) (OR (EQ (SECOND STEP-FORM) VAR) ( IL:* IL:\; "") (EQ (SECOND STEP-FORM) OPERAND))) (PUSH (IL:BQUOTE (QUOTE (IL:\\\, (FIRST STEP-FORM)))) SO-FAR) (LET ((LAMBDA-VAR (MAKE-FAKE-SYMBOL ".X."))) (PUSH (IL:BQUOTE (FUNCTION (LAMBDA ((IL:\\\, LAMBDA-VAR)) (IL:\\\, (SUBLIS (LIST (CONS VAR LAMBDA-VAR) (CONS OPERAND LAMBDA-VAR)) STEP-FORM))))) SO-FAR)))) (VALUES SO-FAR REST)) (DEFUN FILTER-BIND (SO-FAR REST LOSE-CONTINUATION &AUX TOKEN (FIRST T)) (IL:* IL:|;;| "Change BIND to WITH.") (SETQ SO-FAR (CONS (MAKE-FAKE-SYMBOL "WITH") (CDR SO-FAR))) (LOOP (WHEN (NULL REST) (RETURN SO-FAR)) (COND ((EQ (SETQ TOKEN (CAR REST)) (QUOTE IL:OLD)) (FUNCALL LOSE-CONTINUATION "OLD not convertable")) ((CONSP TOKEN) (UNLESS FIRST (PUSH (MAKE-FAKE-SYMBOL "AND") SO-FAR)) (POP REST ) (PUSH (CONVERT (CAR TOKEN)) SO-FAR) (WHEN (EQ (SECOND TOKEN) (QUOTE IL:_)) (SETF SO-FAR (LIST* ( CONVERT (THIRD TOKEN)) (MAKE-FAKE-SYMBOL "=") SO-FAR)))) ((NOT (SYMBOLP TOKEN)) (FUNCALL LOSE-CONTINUATION "Unknown BIND token ~a" TOKEN)) ((EQ (CAR (GET TOKEN (QUOTE IL:CLISPWORD))) (QUOTE IL:FORWORD)) (RETURN (VALUES SO-FAR REST))) (T (UNLESS FIRST (PUSH (MAKE-FAKE-SYMBOL "AND") SO-FAR)) ( PUSH (CONVERT TOKEN) SO-FAR) (POP REST) (WHEN (EQ (CAR REST) (QUOTE IL:_)) (SETF SO-FAR (LIST* ( CONVERT (CADR REST)) (MAKE-FAKE-SYMBOL "=") SO-FAR) REST (CDDR REST))))) (SETQ FIRST NIL))) (DEFUN FILTER-DO (SO-FAR REST IGNORE &AUX TEM) (DECLARE (IGNORE IGNORE)) (LOOP (WHEN (OR (NULL REST) ( AND (SYMBOLP (SETQ TEM (CAR REST))) (EQ (CAR (GET TEM (QUOTE IL:CLISPWORD))) (QUOTE IL:FORWORD)))) ( RETURN (VALUES SO-FAR REST))) (PUSH (CONVERT (COPY-TREE TEM)) SO-FAR) (POP REST))) (DEFUN FILTER-INSTRING (SO-FAR REST IGNORE) (DECLARE (IGNORE IGNORE)) (VALUES (REVAPPEND (IL:BQUOTE (( IL:\\\, (MAKE-FAKE-SYMBOL "BEING")) (IL:\\\, (MAKE-FAKE-SYMBOL "THE")) (IL:\\\, (MAKE-FAKE-SYMBOL "CHARACTERS")) (IL:\\\, (MAKE-FAKE-SYMBOL "OF")) (IL:\\\, (POP REST)))) (CDR SO-FAR)) REST)) (DEFUN FILTER-REPEATWHILE/UNTIL (SO-FAR REST IGNORE) (DECLARE (IGNORE IGNORE)) (LET* ((KEY (STRING ( FAKE-SYMBOL-NAME (POP SO-FAR)))) (VALUE (COND ((STRING= KEY "REPEATWHILE") (IL:BQUOTE (DO (UNLESS ( IL:\\\, (CONVERT (POP REST))) ((IL:\\\, (MAKE-FAKE-SYMBOL "LOOP-FINISH"))))))) ((STRING= KEY "REPEATUNTIL") (IL:BQUOTE (DO (WHEN (IL:\\\, (CONVERT (POP REST))) ((IL:\\\, (MAKE-FAKE-SYMBOL "LOOP-FINISH"))))))) (T (IL:BQUOTE (DO (IL:\\\, (CONVERT (POP REST))))))))) (UNLESS (OR (NULL REST) ( EQ (CAR REST) (QUOTE IL:|finally|))) (LET ((*CURRENT-EXPRESSION* (SECOND VALUE))) (WARN "I.S. oper repeatuntil may need to be moved."))) (VALUES (REVAPPEND VALUE SO-FAR) REST))) (DEFVAR *ADD-REST-ARG* NIL) (DEFVAR *PARAMETERS-ALWAYS-OPTIONAL* NIL) (DEFUN DEFINEQ1 (DEFINEQ-FORM &AUX (NAME (EXTERN (SYMBOL-NAME (FIRST DEFINEQ-FORM)) *IL-PACKAGE*)) ( DEFN (SECOND DEFINEQ-FORM)) (FORMS (CDDR DEFINEQ-FORM)) VARLST) (DECLARE (SPECIAL *LOCALS* *CURRENT-FUNCTION-CALLS* *FUNCTION-CALLS*)) (WHEN FORMS (SETQ DEFN (IL:BQUOTE (LAMBDA (IL:\\\, DEFN) ( IL:\\\,@ FORMS))))) (SETQ VARLST (SECOND DEFN)) (SETQ *CURRENT-FUNCTION-CALLS* (LIST NAME)) (PROG1 ( CASE (FIRST DEFN) (LAMBDA (IF (LISTP VARLST) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) ( EXPAND-VARLIST VARLST) (LET ((*LOCALS* (APPEND VARNAMES *LOCALS*))) (WHEN NEW-VARLST (PUSH (QUOTE &OPTIONAL) NEW-VARLST)) (IL:BQUOTE (DEFUN (IL:\\\, NAME) ((IL:\\\,@ NEW-VARLST) (IL:\\\,@ (AND *ADD-REST-ARG* (QUOTE (&REST $EXTRA-ARGS$))))) (IL:\\\,@ (AND *ADD-REST-ARG* (QUOTE ((DECLARE (IGNORE $EXTRA-ARGS$)))))) (IL:\\\,@ (MAPCONVERT (CDDR DEFN))))))) (LET ((*LOCALS* (ACONS VARLST :LOCAL *LOCALS*))) (IL:BQUOTE (DEFUN (IL:\\\, NAME) (&REST $ARGS$ &AUX ((IL:\\\, VARLST) (LENGTH $ARGS$))) ( IL:\\\,@ (MAPCONVERT (CDDR DEFN)))))))) (NLAMBDA (IF (LISTP VARLST) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST :TYPE :MACRO-ARG) (LET ((*LOCALS* (APPEND VARNAMES *LOCALS*))) (WHEN NEW-VARLST (PUSH (QUOTE &OPTIONAL) NEW-VARLST)) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) ((IL:\\\,@ NEW-VARLST) &REST $EXTRA-ARGS$) (DECLARE (IGNORE $EXTRA-ARGS$)) (IL:\\\, (MAKE-BQ (PROGN-IF-NEEDED ( MAPCONVERT (CDDR DEFN))))))))) (LET ((*LOCALS* (ACONS VARLST :MACRO-ARG *LOCALS*))) (IL:BQUOTE ( DEFMACRO (IL:\\\, NAME) (&REST (IL:\\\, VARLST)) (IL:\\\, (MAKE-BQ (PROGN-IF-NEEDED (MAPCONVERT (CDDR DEFN)))))))))) (T (ERROR "Unknown DEFINEQ type ~a" (FIRST DEFN)))) (PUSH (REVERSE *CURRENT-FUNCTION-CALLS*) *FUNCTION-CALLS*) (SETQ *CURRENT-FUNCTION-CALLS* NIL))) (IL-DEFCONV ARG (VAR M) (DECLARE (IGNORE VAR)) (IL:BQUOTE (NTH (IL:\\\, (SIMP-1- (CONVERT M))) $ARGS$) )) (IL-DEFCONV SETARG (VAR M X) (DECLARE (IGNORE VAR)) (IL:BQUOTE (SETF (NTH (1- (IL:\\\, (CONVERT M))) $ARGS$) (IL:\\\, (CONVERT X))))) (IL-DEFCONV DEFINEQ (&REST ARGS) (PROGN-IF-NEEDED (MAPCAR (QUOTE DEFINEQ1) ARGS))) (IL-DEFCONV PUTD (FN &OPTIONAL DEF &REST EXTRA) (DECLARE (IGNORE EXTRA)) (IL:BQUOTE (IF (NULL (IL:\\\, (CONVERT DEF))) (MAKUNBOUND (IL:\\\, (CONVERT FN))) (SETF (SYMBOL-FUNCTION (IL:\\\, (CONVERT FN))) ( IL:\\\, (CONVERT DEF)))))) (IL-DEFCONV CCODEP (SYM) (LET ((S (MAKE-FAKE-SYMBOL ".X."))) (IL:BQUOTE (LET (((IL:\\\, S) (IL:\\\, ( CONVERT SYM)))) "CCODEP" (AND (FBOUNDP (IL:\\\, S)) (COMPILED-FUNCTION-P (SYMBOL-FUNCTION (IL:\\\, S)) )))))) (IL-COPYDEF SYMBOL-FUNCTION GETD) (IL-COPYDEF APPLY) (IL-COPYDEF FUNCALL APPLY*) (IL-DEFCONV KWOTE (FORM) (IF (IL:CONSTANTEXPRESSIONP FORM) (CONVERT FORM) (IL:BQUOTE (LIST (QUOTE QUOTE) (IL:\\\, (CONVERT FORM)))))) (IL-DEFCONV MOVD (FROM TO &OPTIONAL COPYFLG DONTCOPY) (SETQ *CURRENT-EXPRESSION* (IL:BQUOTE (SETF ( SYMBOL-FUNCTION (IL:\\\, (CONVERT TO))) (SYMBOL-FUNCTION (IL:\\\, (CONVERT FROM)))))) (WHEN (OR COPYFLG DONTCOPY) (WARN "MOVD can't translate argument copyflg or dontcopy")) *CURRENT-EXPRESSION*) (IL-DEFCONV MAP (MAPX MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAP does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPL (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, (CONVERT MAPX))))) (IL-DEFCONV MAPC (MAPX MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAPC does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPC (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, (CONVERT MAPX))))) (IL-DEFCONV MAPLIST (MAPX MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAPLIST does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPLIST (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, ( CONVERT MAPX))))) (IL-DEFCONV MAPCAR (MAPX MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAPCAR does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPCAR (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, ( CONVERT MAPX))))) (IL-DEFCONV MAPCON (MAPX MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAPCON does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPCON (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, ( CONVERT MAPX))))) (IL-DEFCONV MAPCONC (MAPX MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAPCONC does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPCAN (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, ( CONVERT MAPX))))) (IL-DEFCONV MAP2C (MAPX MAPY MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAP2C does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPC (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, ( CONVERT MAPX)) (IL:\\\, (CONVERT MAPY))))) (IL-DEFCONV MAP2CAR (MAPX MAPY MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "MAP2CAR does not yet support MAPFN2 arg")) (IL:BQUOTE (MAPCAR (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, ( CONVERT MAPX)) (IL:\\\, (CONVERT MAPY))))) (IL-DEFCONV SUBSET (MAPX MAPFN1 &OPTIONAL MAPFN2) (WHEN MAPFN2 (ERROR "SUBSET does not yet support MAPFN2 arg")) (IL:BQUOTE (REMOVE-IF-NOT (IL:\\\, (CONVERT MAPFN1)) (IL:\\\, (CONVERT MAPX))))) (IL-WARNINGFORM IL:MOVD?) (DEFVAR *WARN-ON-ERSETQ-NLSETQ* T "Warn on these for later rewrite.") (IL-DEFCONV SHOULDNT (MESS) (IL:BQUOTE (ERROR "Shouldn't happen: ~a" (IL:\\\, (CONVERT MESS))))) (IL-DEFCONV ERROR (&OPTIONAL MESS1 MESS2 NOBREAK) (IL:BQUOTE (ERROR "~a ~a" (IL:\\\, (CONVERT MESS1)) (IL:\\\, (CONVERT MESS2))))) (IL-DEFCONV NLSETQ (FORM) (LIST (MAKE-FAKE-SYMBOL "IGNORE-ERRORS") (CONVERT FORM))) (IL-DEFCONV ERSETQ (&REST FORMS) (LET ((CVAR (MAKE-FAKE-SYMBOL "C"))) (IL:BQUOTE ((IL:\\\, ( MAKE-FAKE-SYMBOL "CONDITION-CASE")) (IL:\\\, (IF (NULL (CDR FORMS)) (CONVERT (FIRST FORMS)) (IL:BQUOTE (PROGN (IL:\\\,. (MAPCONVERT FORMS)))))) (ERROR ((IL:\\\, CVAR)) (PRINC (IL:\\\, CVAR)) (VALUES NIL ( IL:\\\, CVAR))))))) (DEFVAR *EVAL-WHEN-STATE* (QUOTE (LOAD EVAL))) (IL-DEFCONV DECLARE\: (&REST ARGS) (DO ((FORMS NIL) (EVAL-WHEN-EVAL T) (EVAL-WHEN-COMPILE NIL) ( EVAL-WHEN-LOAD T) (FIRST NIL) (TMPFORMS NIL) (FIRSTFORMS NIL) ARG) NIL (WHEN (AND TMPFORMS (OR (ENDP ARGS) (ATOM (FIRST ARGS)))) (LET* ((NEW-EVAL-WHEN-STATE (IL:BQUOTE ((IL:\\\,@ (IF EVAL-WHEN-EVAL ( QUOTE (EVAL)))) (IL:\\\,@ (IF EVAL-WHEN-COMPILE (QUOTE (COMPILE)))) (IL:\\\,@ (IF EVAL-WHEN-LOAD ( QUOTE (LOAD))))))) (OLD-EVAL-WHEN-STATE *EVAL-WHEN-STATE*) (*EVAL-WHEN-STATE* NEW-EVAL-WHEN-STATE)) ( SETQ TMPFORMS (IL:BQUOTE ((IL:\\\, (IF (NULL (SET-DIFFERENCE NEW-EVAL-WHEN-STATE *EVAL-WHEN-STATE*)) ( QUOTE PROGN) (QUOTE EVAL-WHEN))) (IL:\\\,@ (MAPCONVERT (REVERSE TMPFORMS))))))) (IF FIRST (PUSH TMPFORMS FIRSTFORMS) (PUSH TMPFORMS FORMS)) (SETQ TMPFORMS NIL)) (WHEN (ENDP ARGS) (RETURN (CONS ( QUOTE PROGN) (APPEND (REVERSE FIRSTFORMS) (REVERSE FORMS))))) (SETQ ARG (POP ARGS)) (IF (ATOM ARG) ( CASE ARG ((EVAL@LOAD DOEVAL@LOAD) (SETQ EVAL-WHEN-EVAL T)) (DONTEVAL@LOAD (SETQ EVAL-WHEN-EVAL NIL)) ( EVAL@LOADWHEN (SETQ EVAL-WHEN-EVAL (EVAL (POP ARGS)))) ((EVAL@COMPILE DOEVAL@COMPILE) (SETQ EVAL-WHEN-COMPILE T)) (DONTEVAL@COMPILE (SETQ EVAL-WHEN-COMPILE NIL)) (EVAL@COMPILEWHEN (SETQ EVAL-WHEN-COMPILE (EVAL (POP ARGS)))) ((COPY DOCOPY) (SETQ EVAL-WHEN-LOAD T)) (DONTCOPY (SETQ EVAL-WHEN-LOAD NIL)) (COPYWHEN (SETQ EVAL-WHEN-LOAD (EVAL (POP ARGS)))) (FIRST (SETQ FIRST T)) ( NOTFIRST (SETQ FIRST NIL)) (T (WARN "Unknown option ~a in DECLARE:" ARG))) (PUSH ARG TMPFORMS)))) (IL-DEFCONV PUTPROPS (ATM &REST VARS) (DECLARE (SPECIAL *LOCALS*)) (PROGN-IF-NEEDED (DO ((VARS VARS ( REST (REST VARS))) (FORMS NIL)) ((ENDP VARS) (REVERSE FORMS)) (PUSH (CASE (FIRST VARS) ((MACRO DMACRO) (DEFINE-MACRO (EXTERN (SYMBOL-NAME ATM) *IL-PACKAGE*) (SECOND VARS))) (T (IL:BQUOTE (SETF (GET (IL:\\\, (CONVERT (IL:BQUOTE (QUOTE (IL:\\\, ATM))))) (IL:\\\, (CONVERT (IL:BQUOTE (QUOTE (IL:\\\, (FIRST VARS ))))))) (IL:\\\, (CONVERT (IL:BQUOTE (QUOTE (IL:\\\, (SECOND VARS)))))))))) FORMS)))) (DEFUN DEFINE-MACRO (NAME DEFN) (COND ((EQ (CAR DEFN) (QUOTE =)) (IL:BQUOTE (SETF (SYMBOL-FUNCTION ( QUOTE (IL:\\\, NAME))) (SYMBOL-FUNCTION (QUOTE (IL:\\\, (EXTERN (CDR DEFN) *IL-PACKAGE*))))))) (( MEMBER (FIRST DEFN) (QUOTE (LAMBDA OPENLAMBDA)) :TEST (FUNCTION EQ)) (DEFINE-SUBST-MACRO NAME (REST DEFN))) (T (DEFINE-SUBST-MACRO NAME DEFN)))) (DEFUN DEFINE-SUBST-MACRO (NAME DEFN &AUX VARNAMES FORMS ARGLIST) (SETQ VARNAMES (FIRST DEFN)) (SETQ ARGLIST VARNAMES) (SETQ FORMS (REST DEFN)) (WHEN (AND VARNAMES (ATOM VARNAMES)) (SETQ VARNAMES (LIST VARNAMES))) (LET ((*LOCALS* (APPEND (MAPCAR (FUNCTION (LAMBDA (NAME) (IL:BQUOTE ((IL:\\\, NAME) . :MACRO-ARG)))) (MAKE-TRUE-LIST VARNAMES)) *LOCALS*))) (COND ((AND ARGLIST (ATOM ARGLIST)) (IL:BQUOTE ( DEFMACRO (IL:\\\, NAME) (&REST (IL:\\\, ARGLIST)) (IL:\\\, (MAKE-BQ (PROGN-IF-NEEDED (MAPCONVERT FORMS ))))))) ((TRUE-LIST-P ARGLIST) (WHEN ARGLIST (PUSH (QUOTE &OPTIONAL) ARGLIST)) (IL:BQUOTE (DEFMACRO ( IL:\\\, NAME) ((IL:\\\,@ ARGLIST) (IL:\\\,@ (AND *ADD-REST-ARG* (QUOTE (&REST $EXTRA-ARGS$))))) ( IL:\\\,@ (AND *ADD-REST-ARG* (QUOTE ((DECLARE (IGNORE $EXTRA-ARGS$)))))) (IL:\\\, (MAKE-BQ ( PROGN-IF-NEEDED (MAPCONVERT FORMS))))))) (T (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) (IL:\\\, ARGLIST) ( IL:\\\, (MAKE-BQ (PROGN-IF-NEEDED (MAPCONVERT FORMS)))))))))) (IL-DEFCONV QUOTE (ARG) (IL:BQUOTE (QUOTE (IL:\\\, (QUOTE-TREE ARG))))) (DEFVAR *TYPE-CONVERSION-PLIST* (QUOTE (IL:SPECVARS SPECIAL IL:GLOBALVARS NIL))) (IL-DEFCONV DECLARE (&REST ARGS) (IL:BQUOTE (DECLARE (IL:\\\,@ (MAPCAN (FUNCTION (LAMBDA (ARG) (LET (( TYPE (GETF *TYPE-CONVERSION-PLIST* (FIRST ARG) :NOT-FOUND))) (WHEN (AND (EQ TYPE :NOT-FOUND) (STRING= (PACKAGE-NAME (SYMBOL-PACKAGE (FIRST ARG))) "INTERLISP")) (WARN "Unknown type in DECLARE ~s" (FIRST ARG)) (SETQ TYPE (FIRST ARG))) (AND TYPE (IL:BQUOTE (((IL:\\\, TYPE) (IL:\\\,@ (IF (CONSP (REST ARG)) (MAPCONVERT (REST ARG)) NIL))))))))) ARGS))))) (IL-DEFCONV FILEMAP (&REST ARGS) (DECLARE (IGNORE ARGS)) NIL) (IL-DEFCONV ADDTOVAR (VAR &REST ARGS) (IL:BQUOTE (IL:ADDTOVAR (IL:\\\, (CONVERT VAR)) (IL:\\\,@ ( QUOTE-TREE ARGS))))) (IL-DEFCONV APPENDTOVAR (VAR &REST ARGS) (IL:BQUOTE (IL:APPENDTOVAR (IL:\\\, (CONVERT VAR)) (IL:\\\,@ (QUOTE-TREE ARGS))))) (IL-DEFCONV FUNCTION (FN &OPTIONAL ENV) (IL:* IL:|;;| " This should barf on NLAMBDA forms!") (WHEN ENV (WARN "FUNCTION does not support environment")) (COND ((NOT (SYMBOLP FN)) (IL:BQUOTE (FUNCTION (IL:\\\, (CONVERT FN))))) ((GET FN (QUOTE CONVERT-FORM)) (IL:* IL:|;;| "Fake up a way to make it work...") ( LET* ((NEW-AL (MAPCAR (FUNCTION (LAMBDA (X) (GENTEMP "G"))) (IL:ARGLIST FN))) (CONVERSION (CONVERT ( CONS FN NEW-AL)))) (IF (EQUAL (CDR CONVERSION) NEW-AL) (IL:* IL:|;;| "If it turns into a different fcn with the same args, do it the easy way...") (IL:BQUOTE (FUNCTION ( IL:\\\, (CAR CONVERSION)))) (IL:* IL:|;;| "Whole different expression; use full-dress adaptor") ( IL:BQUOTE (FUNCTION (LAMBDA (&OPTIONAL (IL:\\\,. NEW-AL)) (IL:\\\, (LIST (QUOTE IL:*) (QUOTE IL:|;;|) (STRING FN))) (IL:\\\, CONVERSION))))))) (T (IL:BQUOTE (FUNCTION (IL:\\\, (NOTE-EXPORTED-SYMBOL FN)))) ))) (IL-DEFCONV LAMBDA (VARLST &REST FORMS) (IF (LISTP VARLST) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST) (LET ((*LOCALS* (APPEND VARNAMES *LOCALS*))) (IL:BQUOTE (LAMBDA (&OPTIONAL ( IL:\\\,@ NEW-VARLST)) (IL:\\\,@ (MAPCONVERT FORMS)))))) (LET ((*LOCALS* (ACONS VARLST :LOCAL *LOCALS*) )) (IL:BQUOTE (LAMBDA (&REST $ARGS$ &AUX ((IL:\\\, VARLST) (LENGTH $ARGS$))) (IL:\\\,@ (MAPCONVERT FORMS))))))) (IL-DEFCONV DEFINE-FILE-INFO (&REST IGNORE) NIL) (IL-DEFCONV PRETTYCOMPRINT (&REST IGNORE) NIL) (SETF (GET (QUOTE FILECREATED) (QUOTE EARLY)) T) (IL-DEFCONV FILECREATED (&REST JUNK) (CONVERT (LIST* (QUOTE *) (QUOTE |;;;|) "File Created " JUNK))) (IL-DEFCONV CONSTANT (X) (LIST (QUOTE QUOTE) (MAKE-SHARP-COMMA :CONTENTS (CONVERT X)))) (IL-COPYDEF PROCESSP) (IL-DEFCONV CREATE.MONITORLOCK (NAME &OPTIONAL EXCLUSIVE) (SETQ *CURRENT-EXPRESSION* (IL:BQUOTE (( IL:\\\, (MAKE-FAKE-SYMBOL "UE:MAKE-PROCESS-LOCK")) :NAME (IL:\\\, (CONVERT NAME))))) (WHEN EXCLUSIVE ( WARN "CREATE.MONITORLOCK cannot handle arg EXCLUSIVE")) *CURRENT-EXPRESSION*) (IL-DEFCONV OBTAIN.MONITORLOCK (LOCK &OPTIONAL DONTWAIT UNWINDSAVE) (LET* ((PROCESS-LOCK-LOCKER ( MAKE-FAKE-SYMBOL "UE:PROCESS-LOCK-LOCKER")) (CURRENT-PROCESS (MAKE-FAKE-SYMBOL "UE:CURRENT-PROCESS")) (PROCESS-LOCK (MAKE-FAKE-SYMBOL "UE:PROCESS-LOCK")) (WITHOUT-SCHEDULING (MAKE-FAKE-SYMBOL "UE:WITHOUT-SCHEDULING")) (LVAR (MAKE-FAKE-SYMBOL (QUOTE ..L..))) (OVAR (MAKE-FAKE-SYMBOL (QUOTE ..OWNER..))) (BODY (IL:BQUOTE (LET* (((IL:\\\, LVAR) (IL:\\\, (CONVERT LOCK))) ((IL:\\\, OVAR) ((IL:\\\, PROCESS-LOCK-LOCKER) (IL:\\\, LVAR)))) "OBTAIN.MONITORLOCK" (COND ((EQ (IL:\\\, OVAR) ((IL:\\\, CURRENT-PROCESS))) T) ((NULL (IL:\\\, OVAR)) (IF (IL:\\\, (CONVERT DONTWAIT)) ((IL:\\\, WITHOUT-SCHEDULING) (WHEN (NULL ((IL:\\\, PROCESS-LOCK-LOCKER) (IL:\\\, LVAR))) ((IL:\\\, PROCESS-LOCK ) (IL:\\\, LVAR)) (IL:\\\, LVAR))) (PROGN ((IL:\\\, PROCESS-LOCK) (IL:\\\, LVAR)) (IL:\\\, LVAR)))) (T (WHEN (NULL (IL:\\\, DONTWAIT)) ((IL:\\\, PROCESS-LOCK) (IL:\\\, LVAR)) (IL:\\\, LVAR)))))))) (IF UNWINDSAVE (IL:BQUOTE (UNWIND-PROTECT (IL:\\\, BODY) (IL:\\\, (CONVERT UNWINDSAVE)))) BODY))) (IL-DEFCONV RELEASE.MONITORLOCK (LOCK &OPTIONAL EVENIFNOTMINE) (IL:BQUOTE ((IL:\\\, (MAKE-FAKE-SYMBOL "UE:PROCESS-UNLOCK")) (IL:\\\, (CONVERT LOCK)) ((IL:\\\, (MAKE-FAKE-SYMBOL "UE:CURRENT-PROCESS"))) T)) ) (IL-DEFCONV WITH.MONITOR (LOCK &REST BODY) (IL:BQUOTE ((IL:\\\, (MAKE-FAKE-SYMBOL "UE:WITH-PROCESS-LOCK")) (IL:\\\, (CONVERT LOCK)) (IL:\\\,. (MAPCONVERT BODY))))) (IL-DEFCONV NOTIFY.EVENT (EVENT &OPTIONAL ONCEONLY) (SETQ *CURRENT-EXPRESSION* (IL:BQUOTE ((IL:\\\, ( MAKE-FAKE-SYMBOL "UE:PROCESS-UNLOCK")) (IL:\\\, (CONVERT EVENT))))) (WHEN ONCEONLY (WARN "NOTIFY.EVENT cannot handle arg ONCEONLY")) *CURRENT-EXPRESSION*) (IL-DEFCONV THIS.PROCESS (&REST ARGS) (CONS (MAKE-FAKE-SYMBOL "UE:CURRENT-PROCESS") (MAPCONVERT ARGS)) ) (IL-WARNINGFORM IL:AWAIT.EVENT) (IL-WARNINGFORM IL:CREATE.EVENT) (IL-DEFCONV OPENSTRINGSTREAM (STR &OPTIONAL ACCESS) (COND ((OR (NULL ACCESS) (EQUAL ACCESS (QUOTE ( QUOTE IL:INPUT)))) (IL:BQUOTE (MAKE-STRING-INPUT-STREAM (IL:\\\, (CONVERT STR))))) ((EQUAL ACCESS ( QUOTE (QUOTE IL:OUTPUT))) (LET ((BODY (LIST (QUOTE MAKE-STRING-OUTPUT-STREAM)))) (WHEN STR (LET (( *CURRENT-EXPRESSION* BODY)) (WARN "STRING arg to OPENSTRINGSTREAM not translated; use GET-OUTPUT-STREAM-STRING in the appropriate place" ))) BODY)) ((EQUAL ACCESS (QUOTE (QUOTE IL:BOTH))) (WARN "Can't translate OPENSTRINGSTREAM for BOTH.") *CURRENT-EXPRESSION*) (T (WARN "Can't translate OPENSTRINGSTREAM for variable access type.") *CURRENT-EXPRESSION*))) (IL-COPYDEF PRINT) (IL-COPYDEF TERPRI) (IL-COPYDEF PRIN1 PRIN2) (IL-COPYDEF PRINC PRIN1) (IL-COPYDEF READ-CHAR BIN) (IL-COPYDEF WRITE-CHAR BOUT) (DEFVAR *ANNOTATE-PRINTOUT-FORM* NIL "Include the original printout form as an annotation.") (IL-DEFCONV PRINTOUT (STREAM &REST ARGS &AUX SUBSTRINGS FMTARGS FORMS (ARGSTAIL ARGS) ARG) (LOOP (WHEN (NULL ARGSTAIL) (RETURN)) (SETF ARG (POP ARGSTAIL)) (TYPECASE ARG (STRING (PUSH ARG SUBSTRINGS)) ( INTEGER (PUSH (FORMAT NIL "~~~d~:[~;@~]T" (ABS ARG) (MINUSP ARG)) SUBSTRINGS)) (SYMBOL (LABELS (( MAYBE-NUMERIC-ARG (ARG FORMAT) (PUSH "~" SUBSTRINGS) (IF (INTEGERP ARG) (PUSH (WRITE-TO-STRING ARG :BASE 10) SUBSTRINGS) (PROGN (PUSH "V" SUBSTRINGS) (PUSH (CONVERT ARG) FMTARGS))) (PUSH FORMAT SUBSTRINGS)) (ESCAPE-FORM (FORM) (PUSH (IL:BQUOTE (FORMAT (IL:\\\, (OR STREAM T)) (IL:\\\, (APPLY ( FUNCTION CONCATENATE) (QUOTE STRING) (NREVERSE SUBSTRINGS))) (IL:\\\,@ (NREVERSE FMTARGS)))) FORMS) ( PUSH FORM FORMS) (SETQ SUBSTRINGS NIL FMTARGS NIL))) (CASE ARG ((T) (PUSH "~%" SUBSTRINGS)) ((IL:\, IL:|,,| IL:|,,,|) (PUSH (MAKE-STRING (LENGTH (STRING ARG)) :INITIAL-ELEMENT #\Space) SUBSTRINGS)) ( IL:.SP (MAYBE-NUMERIC-ARG (POP ARGSTAIL) "@T")) (IL:.TAB (MAYBE-NUMERIC-ARG (POP ARGSTAIL) "T")) ( IL:.TAB0 (WARN "PRINTOUT command .TAB0 treated like .TAB") (MAYBE-NUMERIC-ARG (POP ARGSTAIL) "T")) ( IL:.SKIP (MAYBE-NUMERIC-ARG (POP ARGSTAIL) "%")) (IL:.PAGE (PUSH "~|" SUBSTRINGS)) (IL:.P2 (PUSH "~s" SUBSTRINGS) (PUSH (CONVERT (POP ARGSTAIL)) FMTARGS)) ((IL:.PPV IL:PPF) (ESCAPE-FORM (IL:BQUOTE (PPRINT (IL:\\\, (CONVERT (POP ARGSTAIL))) (IL:\\\, (CONVERT (OR STREAM T))))))) ((IL:.PPVTL IL:.PPFTL) ( ESCAPE-FORM (IL:BQUOTE (DO ((.X. (IL:\\\, (CONVERT (POP ARGSTAIL))) (CDR .X.))) (NIL) (PPRINT (CAR .X. ) (IL:\\\, (CONVERT (OR STREAM T)))) (UNLESS (CDR .X.) (RETURN)) (WRITE-CHAR #\Space (OR STREAM T))))) ) (IL:\# (ESCAPE-FORM (POP ARGSTAIL))) (OTHERWISE (LET ((SA (SYMBOL-NAME ARG))) (IF (CHAR= (CHAR SA 0) #\.) (WARN "Couldn't translate PRINTOUT command ~a." ARG) (PROGN (PUSH "~a" SUBSTRINGS) (PUSH ( CONVERT ARG) FMTARGS)))))))) (T (PUSH "~a" SUBSTRINGS) (PUSH (CONVERT ARG) FMTARGS)))) (WHEN SUBSTRINGS (PUSH (IL:BQUOTE (FORMAT (IL:\\\, (OR STREAM T)) (IL:\\\, (APPLY (FUNCTION CONCATENATE) ( QUOTE STRING) (NREVERSE SUBSTRINGS))) (IL:\\\,@ (NREVERSE FMTARGS)))) FORMS)) (IF (OR *ANNOTATE-PRINTOUT-FORM* (> (LENGTH FORMS) 1)) (IL:BQUOTE (PROGN (IL:\\\, (LIST (QUOTE IL:*) (QUOTE IL:|;;|) (LET ((*PACKAGE* (FIND-PACKAGE (QUOTE IL)))) (WRITE-TO-STRING (LIST* (QUOTE IL:PRINTOUT) STREAM ARGS))))) (IL:\\\,@ (NREVERSE FORMS)))) (FIRST FORMS))) (IL-DEFCONV READ (STREAM &OPTIONAL RDTBL FLG) (DECLARE (IGNORE FLG)) (IF RDTBL (IL:BQUOTE (LET (( *READTABLE* (IL:\\\, (CONVERT RDTBL)))) (READ (IL:\\\, (CONVERT STREAM))))) (IL:BQUOTE (READ (IL:\\\, (CONVERT STREAM)))))) (IL-DEFCONV READP (FILE &OPTIONAL FLG) (DECLARE (IGNORE FLG)) (IL:BQUOTE (LISTEN (IL:\\\, (CONVERT FILE))))) (IL-COPYCONV PRINTOUT |printout|) (IL-WARNINGFORM IL:INPUT) (IL-WARNINGFORM IL:RATOM) (IL-WARNINGFORM IL:RSTRING) (IL-WARNINGFORM IL:RATOMS) (IL-WARNINGFORM IL:RATEST) (IL-WARNINGFORM IL:READC) (IL-WARNINGFORM IL:PEEKC) (IL-WARNINGFORM IL:LASTC) (IL-WARNINGFORM IL:READCCODE) (IL-WARNINGFORM IL:PEEKCCODE) (IL-WARNINGFORM IL:READP) (IL-WARNINGFORM IL:EOFP) (IL-WARNINGFORM IL:WAITFORINPUT) (IL-WARNINGFORM IL:SKREAD) (IL-WARNINGFORM IL:SKIPSEPRS) (IL-WARNINGFORM IL:OUTPUT) (IL-WARNINGFORM IL:PRIN3) (IL-WARNINGFORM IL:PRIN4) (IL-WARNINGFORM IL:PRINTCCODE) (IL-WARNINGFORM IL:TAB) (IL-WARNINGFORM IL:SHOWPRIN2) (IL-WARNINGFORM IL:SHOWPRINT) (IL-WARNINGFORM IL:PRINTBELLS) (IL-WARNINGFORM IL:LINELENGTH) (IL-WARNINGFORM IL:SETLINELENGTH) (IL-WARNINGFORM IL:WINDOWADDPROP) (IL-WARNINGFORM IL:\\PUTBASE) (IL-WARNINGFORM IL:\\GETBASE) (IL-WARNINGFORM IL:DSPLEFTMARGIN) (IL-WARNINGFORM IL:RESETLST) (IL-WARNINGFORM IL:WINDOWPROP) (IL-WARNINGFORM IL:SMARTARGLIST) (IL-WARNINGFORM IL:EDITGETD) (IL-WARNINGFORM IL:FIND.PROCESS) (IL-WARNINGFORM IL:PROCESS.EVALV) (IL-WARNINGFORM IL:PROCESSP) (IL-WARNINGFORM IL:PROCESS.EVAL) (IL-WARNINGFORM IL:FREEMENU) (IL-WARNINGFORM IL:FM.RESETMENU) (IL-WARNINGFORM IL:FM.CHANGESTATE) (IL-WARNINGFORM IL:FM.CHANGELABEL) (IL-WARNINGFORM IL:FM.ITEMPROP) (IL-WARNINGFORM IL:FM.EDITITEM) (IL-WARNINGFORM IL:FM.GETITEM) (IL-WARNINGFORM IL:MAINWINDOW) (IL-WARNINGFORM IL:RESETFORM) (IL-WARNINGFORM IL:SETTERMTABLE) (IL-WARNINGFORM IL:PROCESSPROP) (IL-WARNINGFORM IL:TTY.PROCESS) (IL-WARNINGFORM IL:CLEARW) (IL-WARNINGFORM IL:\\CARET.DOWN) (IL-WARNINGFORM IL:\\SMASHSTRING) (IL-WARNINGFORM IL:BKSYSBUF) (IL-WARNINGFORM IL:CLEARBUF) (IL-WARNINGFORM IL:GETSYNTAX) (IL-WARNINGFORM IL:OPENWP) (IL-WARNINGFORM IL:STRINGWIDTH) (IL-WARNINGFORM IL:CHARWIDTH) (IL-WARNINGFORM IL:FLASHWINDOW) (IL-WARNINGFORM IL:MENU) (IL-WARNINGFORM IL:FONTCREATE) (IL-WARNINGFORM IL:TTYINPROMPTFORWORD) (IL-WARNINGFORM IL:MOUSECONFIRM) (IL-WARNINGFORM IL:CLOSEW) (IL-WARNINGFORM IL:ATTACHWINDOW) (IL-WARNINGFORM IL:SHAPEW) (IL-WARNINGFORM IL:CONCATLIST) (IL-WARNINGFORM IL:GETPROMPTWINDOW) (IL-WARNINGFORM IL:BITBLT) (IL-WARNINGFORM IL:BLTSHADE) (IL-WARNINGFORM IL:BITMAPWIDTH) (IL-WARNINGFORM IL:BITMAPHEIGHT) (IL-WARNINGFORM IL:FONTPROP) (IL-WARNINGFORM IL:TEDIT.INSERT) (IL-WARNINGFORM IL:TEDIT.PARALOOKS) (IL-WARNINGFORM IL:DSPCLIPPINGREGION) (IL-WARNINGFORM IL:MOVETO) (IL-WARNINGFORM IL:RELMOVETO) (IL-WARNINGFORM IL:DSPFONT) (IL-WARNINGFORM IL:DSPXPOSITION) (IL-WARNINGFORM IL:CURSORCREATE) (IL-WARNINGFORM IL:WAIT.FOR.TTY) (IL-WARNINGFORM IL:\\SAVEVMEMBACKGROUND) (IL-WARNINGFORM IL:GETREGION) (IL-WARNINGFORM IL:WINDOWREGION) (IL-WARNINGFORM IL:EVALV) (IL-WARNINGFORM IL:TTY/EDITE) (IL-WARNINGFORM IL:CLISPTRAN) (IL-WARNINGFORM IL:TTY/EDITL) (IL-WARNINGFORM IL:MARKASCHANGED) (IL-WARNINGFORM IL:FIXEDITDATE) (IL-WARNINGFORM IL:PUTDEF) (IL-WARNINGFORM IL:ADDSPELL) (IL-WARNINGFORM IL:PROCESS.APPLY) (IL-WARNINGFORM IL:STKPOS) (IL-WARNINGFORM IL:EDITMODE) (IL-WARNINGFORM IL:TOTOPW) (IL-WARNINGFORM IL:EXPANDW) (IL-WARNINGFORM IL:ADD.PROCESS) (IL-WARNINGFORM IL:INSIDEP) (IL-WARNINGFORM IL:LASTMOUSEX) (IL-WARNINGFORM IL:LASTMOUSEY) (IL-WARNINGFORM IL:CREATEW) (IL-WARNINGFORM IL:DSPLINEFEED) (IL-WARNINGFORM IL:DSPRIGHTMARGIN) (IL-WARNINGFORM IL:DOWINDOWCOM) (IL-WARNINGFORM IL:TTY.PROCESSP) (IL-WARNINGFORM IL:IN/SCROLL/BAR?) (IL-WARNINGFORM IL:SCROLL.HANDLER) (IL-WARNINGFORM IL:BLOCK) (IL-WARNINGFORM IL:CLOCK) (IL-WARNINGFORM IL:DSPXOFFSET) (IL-WARNINGFORM IL:DSPYOFFSET) (IL-WARNINGFORM IL:CREATEREGION) (IL-WARNINGFORM IL:HEIGHTIFWINDOW) (IL-WARNINGFORM IL:SCROLLW) (IL-WARNINGFORM IL:WXOFFSET) (IL-WARNINGFORM IL:WYOFFSET) (IL-WARNINGFORM IL:KEYDOWNP) (IL-WARNINGFORM IL:SHIFTDOWNP) (IL-WARNINGFORM IL:UNTILMOUSESTATE) (IL-WARNINGFORM IL:FIND-READTABLE) (IL-WARNINGFORM IL:NILL) (IL-WARNINGFORM IL:FILECOMS) (IL-WARNINGFORM IL:ADDFILE) (IL-WARNINGFORM IL:ADDTOFILE) (IL-WARNINGFORM IL:READTABLEPROP) (IL-WARNINGFORM IL:LINELENGTH) (IL-WARNINGFORM IL:GETDEF) (DEFUN CONVERT-FNS (FNS) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (QUOTE CONVERT-ONE-FN) FNS))) (DEFUN CONVERT-ONE-FN (FN) (COND ((SYMBOLP FN)) ((AND (CONSP FN) (EQ (CAR FN) (QUOTE IL:*))) ( RETURN-FROM CONVERT-ONE-FN NIL)) (T (WARN "Unconvertable FNS element: ~s" FN) (RETURN-FROM CONVERT-ONE-FN NIL))) (LET* ((DEFN (IL:VIRGINFN FN)) (NAME FN) (VARLST (SECOND DEFN)) ( *CURRENT-DEFINITION* NAME) (*CURRENT-DEFINITION-TYPE* "Function") (*CURRENT-FUNCTION-CALLS* (LIST NAME )) (*CURRENT-FREE-REFERENCES* (LIST NAME)) (CONVERSION (CASE (FIRST DEFN) ((LAMBDA IL:LAMBDA) (IL:* IL:|;;| "cl:lambda may actually want its own clause...") (IF (LISTP VARLST) (MULTIPLE-VALUE-BIND ( NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST) (LET ((*LOCALS* (COPY-LIST VARNAMES))) (WHEN (AND NEW-VARLST *PARAMETERS-ALWAYS-OPTIONAL*) (PUSH (QUOTE &OPTIONAL) NEW-VARLST)) (IL:BQUOTE (DEFUN (IL:\\\, NAME) ((IL:\\\,@ NEW-VARLST) (IL:\\\,@ (AND *ADD-REST-ARG* (QUOTE (&REST $EXTRA-ARGS$))))) (IL:\\\,@ (AND *ADD-REST-ARG* (QUOTE ((DECLARE (IGNORE $EXTRA-ARGS$)))))) (IL:\\\,@ (MAPCONVERT (CDDR DEFN)))))) ) (LET ((*LOCALS* (ACONS VARLST :LOCAL NIL))) (IL:BQUOTE (DEFUN (IL:\\\, NAME) (&REST $ARGS$ &AUX (( IL:\\\, VARLST) (LENGTH $ARGS$))) (IL:\\\,@ (MAPCONVERT (CDDR DEFN)))))))) (IL:NLAMBDA (IF (LISTP VARLST) (MULTIPLE-VALUE-BIND (NEW-VARLST VARNAMES) (EXPAND-VARLIST VARLST :TYPE :MACRO-ARG) (LET (( *LOCALS* (COPY-LIST VARNAMES))) (WHEN NEW-VARLST (PUSH (QUOTE &OPTIONAL) NEW-VARLST)) (IL:BQUOTE ( DEFMACRO (IL:\\\, NAME) ((IL:\\\,@ NEW-VARLST) &REST $EXTRA-ARGS$) (DECLARE (IGNORE $EXTRA-ARGS$)) ( IL:\\\, (MAKE-BQ (PROGN-IF-NEEDED (MAPCONVERT (CDDR DEFN))))))))) (LET ((*LOCALS* (ACONS VARLST :MACRO-ARG NIL))) (IL:BQUOTE (DEFMACRO (IL:\\\, NAME) (&REST (IL:\\\, VARLST)) (IL:\\\, (MAKE-BQ ( PROGN-IF-NEEDED (MAPCONVERT (CDDR DEFN)))))))))) (T (ERROR "Unknown DEFINEQ type ~a" (FIRST DEFN)))))) (VALUES CONVERSION (NREVERSE *CURRENT-FUNCTION-CALLS*) (NREVERSE *CURRENT-FREE-REFERENCES*)))) (DEFUN CONVERT-CONSTANTS (VARS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (CONS (QUOTE PROGN) ( MAP-INTO-CONTEXT (FUNCTION (LAMBDA (V) (IF (CONSP V) (IL:BQUOTE (DEFCONSTANT (IL:\\\, (FIRST V)) ( IL:\\\, (SECOND V)))) (IL:BQUOTE (DEFCONSTANT (IL:\\\, V) (IL:\\\, (IL:KWOTE (SYMBOL-VALUE V)))))))) VARS))) (DEFUN CONVERT-INITVARS (VARS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (CONS (QUOTE PROGN) ( MAP-INTO-CONTEXT (FUNCTION (LAMBDA (V) (IF (CONSP V) (AND (NOT (EQ (CAR V) (QUOTE IL:*))) (IL:BQUOTE ( DEFVAR (IL:\\\, (FIRST V)) (IL:\\\, (SECOND V))))) (IL:BQUOTE (DEFVAR (IL:\\\, V) NIL))))) VARS))) (DEFUN CONVERT-VARS (VARS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (LET ((*CURRENT-DEFINTION-TYPE* "Variable")) (CONS (QUOTE PROGN) (DELETE (QUOTE NIL) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (V) (LET (( *CURRENT-DEFINITION* V)) (IF (CONSP V) (AND (NOT (EQ (CAR V) (QUOTE IL:*))) (IL:BQUOTE (DEFPARAMETER ( IL:\\\, (NOTE-EXPORTED-SYMBOL (FIRST V))) (IL:\\\, (CONVERT (SECOND V)))))) (IF (BOUNDP V) (IL:BQUOTE (DEFPARAMETER (IL:\\\, (NOTE-EXPORTED-SYMBOL V)) (IL:\\\, (IL:KWOTE (SYMBOL-VALUE V))))) (PROGN (WARN "Var ~s not bound; no form dumped." V) NIL)))))) VARS))))) (DEFUN CONVERT-MACROS (FNS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (CONS (QUOTE PROGN) (DELETE (QUOTE NIL) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (F &AUX TEMPLATE) (WHEN (OR (SETQ TEMPLATE (GET F (QUOTE IL:MACRO))) (SETQ TEMPLATE (GET F (QUOTE IL:DMACRO)))) (LET ((*CURRENT-DEFINITION* F) ( *CURRENT-DEFINITION-TYPE* "Macro")) (DEFINE-MACRO F TEMPLATE))))) FNS)))) (DEFUN CONVERT-ADDVARS (LISTS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (CONS (QUOTE PROGN) ( MAP-INTO-CONTEXT (FUNCTION (LAMBDA (L) (IL:BQUOTE (SETQ (IL:\\\, (CAR L)) (LIST* (QUOTE (IL:\\\, (CDR L))) (AND (BOUNDP (QUOTE (IL:\\\, (CAR L)))) (IL:\\\, (CAR L)))))))) LISTS))) (DEFUN CONVERT-APPENDVARS (LISTS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (CONS (QUOTE PROGN) ( MAP-INTO-CONTEXT (FUNCTION (LAMBDA (L) (IL:BQUOTE (SETQ (IL:\\\, (CAR L)) (APPEND (AND (BOUNDP (QUOTE (IL:\\\, (CAR L)))) (IL:\\\, (CAR L))) (QUOTE (IL:\\\, (CDR L)))))))) LISTS))) (DEFUN CONVERT-ALISTS (LISTS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (CONS (QUOTE PROGN) ( MAP-INTO-CONTEXT (FUNCTION (LAMBDA (L &AUX (SYM (CAR L)) (KEYS (CDR L))) (LABELS ((DOTAIL (TAIL) ( IL:BQUOTE (ACONS (QUOTE (IL:\\\, (CAR TAIL))) (QUOTE (IL:\\\, (CDR (ASSOC (CAR TAIL) (SYMBOL-VALUE SYM ))))) (IL:\\\, (IF (ENDP (CDR TAIL)) (IL:BQUOTE (AND (BOUNDP (QUOTE (IL:\\\, SYM))) (IL:\\\, SYM))) ( DOTAIL (CDR TAIL)))))))) (IL:BQUOTE (SETQ (IL:\\\, SYM) (IL:\\\, (DOTAIL KEYS))))))) LISTS))) (DEFUN CONVERT-PROP (STUFF &OPTIONAL MAPPING-FN-IGNORED) (DECLARE (IGNORE MAPPING-FN-IGNORED)) (LET* ( (INDICATOR (FIRST STUFF)) (INDICATORS (IF (CONSP INDICATOR) INDICATOR (CONS INDICATOR NIL))) (SYMS ( CDR STUFF)) (FORM (SECOND SYMS)) (IL:* IL:\; "if indirect...") (NOPROPVALUE (CONS NIL NIL))) (WHEN (EQ (FIRST SYMS) (QUOTE IL:*)) (IL:* IL:|;;| "indirect...") (SETQ SYMS (IL:EVAL FORM))) ( MAPCAN-INTO-CONTEXT (QUOTE SETF) (FUNCTION (LAMBDA (S) (MAPCAN (FUNCTION (LAMBDA (I) (LET ((VALUE (GET S I NOPROPVALUE))) (WHEN (EQ VALUE NOPROPVALUE) (WARN "No ~s property for ~s" I S) (SETQ VALUE NIL)) (IL:BQUOTE ((GET (QUOTE (IL:\\\, S)) (QUOTE (IL:\\\, I))) (IL:\\\, (IL:KWOTE VALUE))))))) INDICATORS)) ) SYMS))) (DEFUN CONVERT-PROPS (PAIRS &AUX (NOPROPVALUE (CONS NIL NIL))) (DECLARE (IGNORE MAPPING-FN-IGNORED)) ( MAPCAN-INTO-CONTEXT (QUOTE SETF) (FUNCTION (LAMBDA (P) (LET ((S (FIRST P)) (I (SECOND P))) (LET (( VALUE (GET S I NOPROPVALUE))) (WHEN (EQ VALUE NOPROPVALUE) (WARN "No ~s property for ~s" I S) (SETQ VALUE NIL)) (IL:BQUOTE ((GET (QUOTE (IL:\\\, S)) (QUOTE (IL:\\\, I))) (IL:\\\, (IL:KWOTE VALUE)))))))) PAIRS)) (DEFUN CONVERT-IFPROP (STUFF &OPTIONAL MAPPING-FN-IGNORED) (DECLARE (IGNORE MAPPING-FN-IGNORED)) (LET* ((INDICATOR (FIRST STUFF)) (INDICATORS (IF (CONSP INDICATOR) INDICATOR (CONS INDICATOR NIL))) (SYMS ( CDR STUFF)) (FORM (SECOND SYMS)) (IL:* IL:\; "if indirect") (NOPROPVALUE (CONS NIL NIL))) (WHEN (EQ ( FIRST SYMS) (QUOTE IL:*)) (SETQ SYMS (IL:EVAL FORM))) (MAPCAN (QUOTE SETF) (FUNCTION (LAMBDA (S) ( MAPCAN (FUNCTION (LAMBDA (I) (BLOCK NIL (LET ((VALUE (GET S I NOPROPVALUE))) (WHEN (EQ VALUE NOPROPVALUE) (WARN "No ~s property for ~s" I S) (RETURN NIL)) (IL:BQUOTE ((GET (QUOTE (IL:\\\, S)) ( QUOTE (IL:\\\, I))) (IL:\\\, (IL:KWOTE VALUE)))))))) INDICATORS))) SYMS))) (DEFUN CONVERT-RECORDS (RECS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (DECLARE (SPECIAL IL:USERRECLST)) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (R) (LET* ((DECL (CAR (IL:\\RECORDBLOCK/RECLOOK1 R IL:USERRECLST)))) (CONVERT DECL)))) RECS))) (DEFUN CONVERT-FILES-FILECOM (FILES &AUX (NOERRORS)) (WHEN (MEMBER (QUOTE COMPILE) *EVAL-WHEN-STATE*) (IL:DOFILESLOAD FILES)) (UNLESS (NULL (INTERSECTION (QUOTE (LOAD EVAL)) *EVAL-WHEN-STATE*)) (CONS ( QUOTE PROGN) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (F) (COND ((CONSP F) (WHEN (MEMBER (QUOTE IL:NOERRORS ) F) (SETQ NOERRORS T)) (LET ((UNSUP (REMOVE (QUOTE IL:NOERRORS) F))) (WHEN UNSUP (WARN "FILES options not supported: ~:@(~{~A ~}~)" UNSUP)))) (T (TRANSLATOR-NOTE-ADDITIONAL-FILE F) (IL:BQUOTE (LOAD (IL:\\\, (STRING F)) (IL:\\\,@ (AND NOERRORS (QUOTE (:IF-DOES-NOT-EXIST NIL)))))))))) FILES)))) (DEFUN CONVERT-TOP-LEVEL-FORM-FILECOM (FORMS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR))) (CONS (QUOTE PROGN ) (MAP-INTO-CONTEXT (QUOTE CONVERT) FORMS))) (DEFUN CONVERT-COMMENT-FILECOM (BODY) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (B) (CONS (QUOTE IL:*) BODY) )) (LIST BODY))) (DEFUN CONVERT-COMS-FILECOM (COMS) (MAPC (QUOTE CONVERT-ONE-FILECOM) COMS)) (DEFUN CONVERT-DECLARE-FILECOM (ARGS) (DO ((FORMS NIL) (EVAL-WHEN-EVAL (MEMBER (QUOTE EVAL) *EVAL-WHEN-STATE*)) (EVAL-WHEN-COMPILE (MEMBER (QUOTE COMPILE) *EVAL-WHEN-STATE*)) (EVAL-WHEN-LOAD ( MEMBER (QUOTE LOAD) *EVAL-WHEN-STATE*)) (FIRST NIL) (TMPFORMS NIL) (FIRSTFORMS NIL) ARG) NIL (WHEN ( AND TMPFORMS (OR (ENDP ARGS) (ATOM (FIRST ARGS)))) (LET* ((NEW-EVAL-WHEN-STATE (IL:BQUOTE ((IL:\\\,@ ( IF EVAL-WHEN-EVAL (QUOTE (EVAL)))) (IL:\\\,@ (IF EVAL-WHEN-COMPILE (QUOTE (COMPILE)))) (IL:\\\,@ (IF EVAL-WHEN-LOAD (QUOTE (LOAD))))))) (OLD-EVAL-WHEN-STATE *EVAL-WHEN-STATE*) (*EVAL-WHEN-STATE* NEW-EVAL-WHEN-STATE) (OLD-LAST-CONS (AND *FILE-CONTEXT* (FILE-CONTEXT-DEFINITIONS-LAST-CONS *FILE-CONTEXT*)))) (IL:* IL:|;;| "The way things are dropped directly into the context, we need to re-group them by performing some micro-surgery on the list structure on the fly." ) (MAPC (QUOTE CONVERT-ONE-FILECOM) (NREVERSE TMPFORMS)) (WHEN *FILE-CONTEXT* (IF (NULL OLD-LAST-CONS) (IL:* IL:|;;| "This com was the first one... special case...") (LET ((NEW-FORM (CONS (IL:BQUOTE ( EVAL-WHEN (IL:\\\, NEW-EVAL-WHEN-STATE) (IL:\\\,@ (FILE-CONTEXT-DEFINITIONS *FILE-CONTEXT*)))) NIL))) (SETF (FILE-CONTEXT-DEFINITIONS *FILE-CONTEXT*) NEW-FORM) (FILE-CONTEXT-DEFINITIONS-LAST-CONS *FILE-CONTEXT*) NEW-FORM) (IL:* IL:|;;| " Not the first com in the file...") (SETF (CDR OLD-LAST-CONS) (IL:BQUOTE ((EVAL-WHEN (IL:\\\, NEW-EVAL-WHEN-STATE) (IL:\\\,@ (CDR OLD-LAST-CONS))))) ( FILE-CONTEXT-DEFINITIONS-LAST-CONS *FILE-CONTEXT*) (LAST OLD-LAST-CONS))))) (IF FIRST (PUSH TMPFORMS FIRSTFORMS) (PUSH TMPFORMS FORMS)) (SETQ TMPFORMS NIL)) (WHEN (ENDP ARGS) (RETURN)) (SETQ ARG (POP ARGS)) (IF (ATOM ARG) (CASE ARG ((IL:EVAL@LOAD IL:DOEVAL@LOAD) (SETQ EVAL-WHEN-EVAL T)) ( IL:DONTEVAL@LOAD (SETQ EVAL-WHEN-EVAL NIL)) (IL:EVAL@LOADWHEN (SETQ EVAL-WHEN-EVAL (EVAL (POP ARGS)))) ((IL:EVAL@COMPILE IL:DOEVAL@COMPILE) (SETQ EVAL-WHEN-COMPILE T)) (IL:DONTEVAL@COMPILE (SETQ EVAL-WHEN-COMPILE NIL)) (IL:EVAL@COMPILEWHEN (SETQ EVAL-WHEN-COMPILE (EVAL (POP ARGS)))) ((IL:COPY IL:DOCOPY) (SETQ EVAL-WHEN-LOAD T)) (IL:DONTCOPY (SETQ EVAL-WHEN-LOAD NIL)) (IL:COPYWHEN (SETQ EVAL-WHEN-LOAD (EVAL (POP ARGS)))) (IL:FIRST (WARN "\"FIRST\" option in DECLARE: was ignored.")) ( IL:NOTFIRST (SETQ FIRST NIL)) (T (WARN "Unknown option ~:@(~a~) in DECLARE:" ARG))) (PUSH ARG TMPFORMS )))) (DEFUN CONVERT-EXPORT-FILECOM (COM &OPTIONAL MAPPING-FN-IGNORED) (DECLARE (IGNORE MAPPING-FN-IGNORED)) NIL) (DEFUN CONVERT-FUNCTIONS-FILECOM (FUNCTIONS) (IL:* IL:|;;| "Use the Code-Walker (stolen from Gregor's PCL) to hunt down any lingering IL code in CL functions..." ) (FLET ((CONVERT-FUNCTION (F) (LET* ((DEF (FUNCALL (GET (QUOTE IL:FUNCTIONS) (QUOTE IL:GETDEF)) F ( QUOTE IL:FUNCTIONS))) (IL:* IL:|;;| " The def name will be added by the template walker...") ( *CURRENT-FUNCTION-CALLS* NIL) (*CURRENT-FREE-REFERENCES* NIL) (*CURRENT-DEFINITION* NIL) ( *CURRENT-DEFINITION-TYPE* "Function") (CONVERSION (WALK-FORM-INTERNAL DEF))) (VALUES CONVERSION ( NREVERSE *CURRENT-FUNCTION-CALLS*) (NREVERSE *CURRENT-FREE-REFERENCES*))))) (CONS (QUOTE PROGN) ( MAP-INTO-CONTEXT (FUNCTION CONVERT-FUNCTION) FUNCTIONS)))) (DEFUN CONVERT-ONE-BITMAP (VARNAME) (LET* ((B (SYMBOL-VALUE VARNAME)) (A (MAKE-ARRAY (LIST ( IL:BITMAPHEIGHT B) (IL:BITMAPWIDTH B)) :ELEMENT-TYPE (QUOTE BIT)))) (IL:* IL:|;;| "Oughta be a better way...") (IL:FOR J IL:TO (IL:BITMAPWIDTH B) IL:DO (IL:FOR I IL:TO (IL:BITMAPHEIGHT B) IL:DO (SETF (AREF A (1- I) (1- J)) (IL:BITMAPBIT B J I)))) (IL:* IL:|;;| "This must print out with *print-array* on.") (IL:BQUOTE (DEFPARAMETER (IL:\\\, VARNAME) (QUOTE (IL:\\\, A)))))) (DEFUN CONVERT-BITMAPS (VARS) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (QUOTE CONVERT-ONE-BITMAP) VARS))) (DEFUN CONVERT-VARIABLES-FILECOM (VARS &OPTIONAL (MAPPING-FN (QUOTE MAPCAR)) &AUX (GETD (GET (QUOTE IL:VARIABLES) (QUOTE IL:GETDEF)))) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (V) ( FUNCALL GETD V (QUOTE IL:VARIABLES)))) VARS))) (DEFUN CONVERT-STRUCTURES-FILECOM (STRUCTURES &OPTIONAL (MAPPING-FN (QUOTE MAPCAR)) &AUX (GETD (GET ( QUOTE IL:STRUCTURES) (QUOTE IL:GETDEF)))) (CONS (QUOTE PROGN) (MAP-INTO-CONTEXT (FUNCTION (LAMBDA (S) (FUNCALL GETD S (QUOTE IL:STRUCTURES)))) STRUCTURES))) (IL:PUTPROPS IL:FNS CONVERT-COM CONVERT-FNS) (IL:PUTPROPS IL:CONSTANTS CONVERT-COM CONVERT-CONSTANTS) (IL:PUTPROPS IL:INITVARS CONVERT-COM CONVERT-INITVARS) (IL:PUTPROPS IL:VARS CONVERT-COM CONVERT-VARS) (IL:PUTPROPS IL:MACROS CONVERT-COM CONVERT-MACROS) (IL:PUTPROPS IL:ADDVARS CONVERT-COM CONVERT-ADDVARS) (IL:PUTPROPS IL:APPENDVARS CONVERT-COM CONVERT-APPENDVARS) (IL:PUTPROPS IL:ALISTS CONVERT-COM CONVERT-ALISTS) (IL:PUTPROPS IL:PROP CONVERT-COM CONVERT-PROP) (IL:PUTPROPS IL:PROPS CONVERT-COM CONVERT-PROPS) (IL:PUTPROPS IL:IFPROP CONVERT-COM CONVERT-IFPROP) (IL:PUTPROPS IL:RECORDS CONVERT-COM CONVERT-RECORDS) (IL:PUTPROPS IL:INITRECORDS CONVERT-COM CONVERT-RECORDS) (IL:PUTPROPS IL:FILES CONVERT-COM CONVERT-FILES-FILECOM) (IL:PUTPROPS IL:P CONVERT-COM CONVERT-TOP-LEVEL-FORM-FILECOM) (IL:PUTPROPS IL:* CONVERT-COM CONVERT-COMMENT-FILECOM) (IL:PUTPROPS IL:COMS CONVERT-COM CONVERT-COMS-FILECOM) (IL:PUTPROPS IL:DECLARE\: CONVERT-COM CONVERT-DECLARE-FILECOM) (IL:PUTPROPS EXPORT CONVERT-COM CONVERT-COMS-FILECOM) (IL:PUTPROPS IL:FUNCTIONS CONVERT-COM CONVERT-FUNCTIONS-FILECOM) (IL:PUTPROPS IL:VARIABLES CONVERT-COM CONVERT-VARIABLES-FILECOM) (IL:PUTPROPS IL:STRUCTURES CONVERT-COM CONVERT-STRUCTURES-FILECOM) (IL:PUTPROPS IL:SETFS CONVERT-COM CONVERT-SETFS-FILECOM) (IL:PUTPROPS IL:BITMAPS CONVERT-COM CONVERT-BITMAPS) (DEFSTRUCT (IL-COMMENT-STRUCT (:PRINT-FUNCTION PRINT-IL-COMMENT-STRUCT)) STUFF) (DEFUN PRINT-IL-COMMENT-STRUCT (O S D) (LET ((STUFF (IL-COMMENT-STRUCT-STUFF O))) (COND ((SOME ( FUNCTION (LAMBDA (X) (AND (CONSP X) (SOME (QUOTE CONSP) X)))) STUFF) (IL:* IL:|;;| "Commenting out a form? Try it this way...") (PRINC "#||" S) (PRIN1 STUFF S) (PRINC "||#" S)) (T ( UNLESS (AND (TYPEP (FIRST STUFF) (QUOTE (OR SYMBOL STRING))) (EQL (CHAR (STRING (FIRST STUFF)) 0) #\;) ) (PRINC "; " S)) (DOLIST (I STUFF) (PRINC I S) (WRITE-CHAR #\Space S)) (TERPRI S))))) (IL-DEFCONV * (&REST STUFF) (IF (AND (MEMBER (CAR STUFF) (QUOTE (IL:\; IL:|;;| IL:|;;;| IL:|;;;;| IL:\#\|))) (STRINGP (SECOND STUFF)) (NULL (CDDR STUFF))) (CONS (QUOTE IL:*) STUFF) (LET ((STR (FORMAT NIL "~{~a ~}" STUFF))) (LIST (QUOTE IL:*) (IF (< (LENGTH STR) 32) (QUOTE IL:\;) (QUOTE IL:|;;|)) STR)) )) (IL:PUTPROPS IL:IL-SIM IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (IN-PACKAGE "IL-CONVERT") *PACKAGE*) :BASE 10)) (IL:PUTPROPS IL:IL-SIM IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:IL-SIM IL:COPYRIGHT ("ENVOS Corporation" 1989 1990)) NIL \ No newline at end of file diff --git a/lispusers/MIGRATION/IL-STARTUP b/lispusers/MIGRATION/IL-STARTUP new file mode 100644 index 00000000..353150f2 --- /dev/null +++ b/lispusers/MIGRATION/IL-STARTUP @@ -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 diff --git a/lispusers/MIGRATION/IL-STARTUP.LCOM b/lispusers/MIGRATION/IL-STARTUP.LCOM new file mode 100644 index 00000000..3aa4c9e7 --- /dev/null +++ b/lispusers/MIGRATION/IL-STARTUP.LCOM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (LET ((*PACKAGE* *PACKAGE*)) (CLIN-PACKAGE "IL-CONVERT") *PACKAGE*) BASE 10) (IL:FILECREATED "19-Jan-93 19:56:33" ("compiled on " IL:|{DSK}local>src>tape>MIGRATION>IL-STARTUP.;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 "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|) (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))) (EVAL-WHEN (LOAD COMPILE EVAL) (DEFVAR *IL-PACKAGE* (FIND-PACKAGE "INTERLISP"))) (DEFVAR *IL-SIM-PACKAGE* (MAKE-PACKAGE "IL-SIM" :USE NIL)) (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) (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)))) (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)) NIL \ No newline at end of file diff --git a/lispusers/MIGRATION/MIGRATION-TOOL b/lispusers/MIGRATION/MIGRATION-TOOL new file mode 100644 index 00000000..ac77fa41 --- /dev/null +++ b/lispusers/MIGRATION/MIGRATION-TOOL @@ -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 diff --git a/lispusers/MIGRATION/MIGRATION-TOOL.LCOM b/lispusers/MIGRATION/MIGRATION-TOOL.LCOM new file mode 100644 index 00000000..726111b2 --- /dev/null +++ b/lispusers/MIGRATION/MIGRATION-TOOL.LCOM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO PACKAGE (DEFPACKAGE "IL-CONVERT") READTABLE "XCL") (IL:FILECREATED "19-Jan-93 19:56:49" ("compiled on " IL:|{DSK}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 \ No newline at end of file diff --git a/lispusers/MIGRATION/SEDIT-DECLS b/lispusers/MIGRATION/SEDIT-DECLS new file mode 100644 index 00000000..1b026c3e --- /dev/null +++ b/lispusers/MIGRATION/SEDIT-DECLS @@ -0,0 +1,242 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) +(il:filecreated "18-Apr-88 13:01:03" il:{eris}sources>sedit-decls.\;21 32113 + + il:|changes| il:|to:| (il:vars il:sedit-declscoms) + + il:|previous| il:|date:| "13-Apr-88 17:22:16" il:{eris}sources>sedit-decls.\;20) + + +; Copyright (c) 1987, 1988 by Xerox Corporation. All rights reserved. + +(il:prettycomprint il:sedit-declscoms) + +(il:rpaqq il:sedit-declscoms ((il:prop il:filetype il:sedit-decls) (il:prop il:makefile-environment il:sedit-decls) (il:* il:|;;;| "This file is for declaring things which are shared among sedit files. This file is loaded at compile time by each sedit file, but the contents of this file are not copied into any of the compiled files. The RECORDS declarations are here, and they are INITRECORDed and SYSRECORDed in SEDIT-ACCESS. If you change a record, make sure sedit-access gets remade NEW. All GLOBALVARS declarations are done here, because they're needed at compile time, but the actual variable declarations are done in the appropriate file. Constants and Macros are declared here only if they are shared among files; otherwise they can remain in the appropriate file. ") (il:records broken-atom edit-context edit-env edit-node edit-node-type edit-point edit-selection gap line-block line-start list-format open-string string-item weak-link) (il:* il:|;;| "interface globalvars") (il:globalvars convert-upgrade keep-window-region contexts lisp-edit-environment list-formats-table pretty-print-env regions) (il:* il:|;;| "shared globalvars") (il:globalvars il:boldfont il:clispfont il:commentflg il:commentfont il:defaultfont il:promptwindow il:italicfont args-gap atom-caret basic-gap body-gap button-string button-string-node structure-caret clisp-indent-words clisp-program-words command-table-spec list-parse-info terminal-table temp-point temp-selection type-clisp type-comment type-comment-word type-dotlist type-gap type-list type-litatom type-quote type-root type-string type-unknown types args-bitmap body-bitmap gap-bitmap) (il:* il:|;;| "window file globalvars") (il:globalvars titled-icon selection-pending? pending-selection initial-selection scratch-selection pending-caret pending-last-x pending-last-y pending-type pending-shift last-move-clock button-string-node) (il:* il:|;;| "command file globalvars") (il:globalvars menus menu-description mutate-candidate package-candidate printbase-candidate find-candidate substitute-candidate) (il:* il:|;;| "random constants") (il:constants (editor-name "SEdit") (il:micasperpt 35.27778) (quote-wrapper-list (quote (quote quote il:bquote il:bquote il:comma il:\\\, comma-at il:\\\,@ comma-dot il:\\\,. function function)))) (il:* il:|;;| "random macros") (il:macros get-prompt-window eval-in-process lookup-command quote-wrapper quote-wrapper-name repaint-new-line reset-control-variables select-comment-indent set-comment-positions set-selection-nowhere) (il:* il:|;;| "kernel macros") (il:functions create-weak-link) (il:macros advance close-open-node dead-node? end-undo-block escape-char eq-point-type next-linear set-linear start-undo-block step-linear subnode undo-by zap-clisp-translation smash-using il:half) (il:* il:|;;| "the symbols that come from interlisp, divided into those that conflict with CL symbols and those that don't. The SEDIT package declaration in the makefile-environment for all these files need not actually import any of these symbols, it just makes the functions easier to edit if you do cause then you don't need so many IL: prefixes.") (il:variables *il-cl-conflicts* *il-imports*) (il:* il:|;;| "and a little reminder:") (il:p (il:|printout| t t "EXPORTS.ALL must be loaded to compile SEdit" t) (il:|printout| t t "SEDIT-ACCESS must be REMADE NEW if you change a record" t)))) + +(il:putprops il:sedit-decls il:filetype :compile-file) + +(il:putprops il:sedit-decls il:makefile-environment (:readtable "XCL" :package (defpackage il:sedit (:use il:lisp il:xcl)))) + + + +(il:* il:|;;;| +"This file is for declaring things which are shared among sedit files. This file is loaded at compile time by each sedit file, but the contents of this file are not copied into any of the compiled files. The RECORDS declarations are here, and they are INITRECORDed and SYSRECORDed in SEDIT-ACCESS. If you change a record, make sure sedit-access gets remade NEW. All GLOBALVARS declarations are done here, because they're needed at compile time, but the actual variable declarations are done in the appropriate file. Constants and Macros are declared here only if they are shared among files; otherwise they can remain in the appropriate file. " +) + +(il:declare\: il:eval@compile + +(il:datatype broken-atom (atom-chars)) + +(il:datatype edit-context (environment profile eval-fn eval-in-process context-lock completion-event edit-type icon-title edit-options comment-width comment-separation find-candidate substitute-candidate display-window window-left window-bottom window-right window-top root root-changed-fn completion-fn changed-structure? (dont-collect-changes? il:flag) changed-nodes open-node-changed? open-node open-node-info atom-started atom-started-undo-pointer undo-list undo-undo-list caret caret-point selection selection-displayed? (current-node il:fullxpointer) current-x (current-line il:fullxpointer) (last-linearized-sub-node-index il:word) (linear-pointer il:fullxpointer) (linear-prev il:fullxpointer) last-mouse-x last-mouse-y last-mouse-type \\x \\y \\z \\t first-block current-block matching? below? visible? (repaint-start il:fullxpointer) (repaint-line il:fullxpointer) repaint-x relinearization-time-stamp shift-y shift-down shift-right) + changed-nodes il:_ (cons)) + +(il:datatype edit-env (parse-info parse-info-unknown user-data default-font italic-font keyword-font comment-font broken-atom-font space-width default-line-skip em-width indent-base indent-step max-width comment-width-percent init-comment-separation lparen-string rparen-string dot-string quote-string comment-string command-table default-char-handler help-menu) +) + +(il:datatype edit-node ((node-type il:fullxpointer) format unassigned (super-node il:fullxpointer) (depth il:word) (sub-node-index il:word) structure sub-nodes (linear-thread il:fullxpointer) linear-form (start-x il:word) (right-margin il:word) (preferred-width il:word) (actual-width il:word) (changed? il:flag) inline-width actual-llength first-line last-line) + (il:accessfns (inline? (eq (il:|fetch| first-line il:|of| il:datum) (il:|fetch| last-line il:|of| il:datum)))) + format il:_ (quote not-yet-assigned)) + +(il:datatype edit-node-type (name assign-format compute-format-values linearize sub-node-changed set-point compute-point-position compute-selection-position set-selection grow-selection select-segment insert delete copy-structure copy-selection stringify back-space close-node) +) + +(il:datatype edit-point ((point-node il:fullxpointer) point-index point-type point-x (point-line il:fullxpointer) point-string point-offset) +) + +(il:datatype edit-selection ((select-node il:fullxpointer) select-start select-end select-type delete-ok? pending-delete? select-start-x (select-start-line il:fullxpointer) select-end-x (select-end-line il:fullxpointer) select-string select-start-offset select-end-offset) +) + +(il:datatype gap (linear-item)) + +(il:datatype line-block ((block-start il:fullxpointer) block-new-x block-width next-block bits? block-x block-base-line block-ascent block-descent) +) + +(il:datatype line-start ((next-line il:fullxpointer) (prev-line il:fullxpointer) (node il:fullxpointer) (line-ascent il:word) (line-descent il:word) (line-skip il:word) (line-length il:word) (indent il:word) ycoord (cache-time il:word) cached-y (cached-ascent il:word) (cached-descent il:word)) + (il:accessfns (line-height (il:iplus (il:fetch line-skip il:of il:datum) (il:fetch line-ascent il:of il:datum) (il:fetch line-descent il:of il:datum)))) + (il:accessfns (base-line-y (il:idifference (il:add1 (il:fetch ycoord il:of il:datum)) (il:iplus (il:fetch line-skip il:of il:datum) (il:fetch line-ascent il:of il:datum))))) + (il:accessfns (next-line-y (il:idifference (il:fetch ycoord il:of il:datum) (il:fetch line-height il:of il:datum)))) + (il:accessfns (old-top (if (eq (il:fetch cache-time il:of il:datum) (il:|fetch| relinearization-time-stamp il:|of| context)) (il:sub1 (il:iplus (il:fetch cached-y il:of il:datum) (il:fetch cached-ascent il:of il:datum))) (il:fetch ycoord il:of il:datum)))) + (il:accessfns (old-bottom (if (eq (il:fetch cache-time il:of il:datum) (il:|fetch| relinearization-time-stamp il:|of| context)) (il:idifference (il:fetch cached-y il:of il:datum) (il:fetch cached-descent il:of il:datum)) (il:add1 (il:fetch next-line-y il:of il:datum))))) +) + +(il:datatype list-format (list-formats list-inline? list-pformat list-mformat list-sublists) (il:accessfns (non-standard? (null (il:|fetch| list-formats il:|of| il:datum)))) + (il:accessfns (set-format-list (il:|fetch| list-inline? il:|of| il:datum))) (il:accessfns (cfvlist (il:|fetch| list-pformat il:|of| il:datum))) + (il:accessfns (linearize-list (il:|fetch| list-mformat il:|of| il:datum))) list-sublists il:_ nil) + +(il:record open-string (real-length substring . buffer-string)) + +(il:datatype string-item (string (width il:word) (font il:fullxpointer) (prin-2? il:flag))) + +(il:datatype weak-link ((destination il:fullxpointer))) +) + +(il:/declaredatatype (quote broken-atom) (quote (il:pointer)) (quote ((broken-atom 0 il:pointer))) (quote 2)) + +(il:/declaredatatype (quote edit-context) (quote (il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:flag il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:fullxpointer il:pointer il:fullxpointer il:word il:fullxpointer il:fullxpointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:fullxpointer il:fullxpointer il:pointer il:pointer il:pointer il:pointer il:pointer)) (quote ((edit-context 0 il:pointer) (edit-context 2 il:pointer) (edit-context 4 il:pointer) (edit-context 6 il:pointer) (edit-context 8 il:pointer) (edit-context 10 il:pointer) (edit-context 12 il:pointer) (edit-context 14 il:pointer) (edit-context 16 il:pointer) (edit-context 18 il:pointer) (edit-context 20 il:pointer) (edit-context 22 il:pointer) (edit-context 24 il:pointer) (edit-context 26 il:pointer) (edit-context 28 il:pointer) (edit-context 30 il:pointer) (edit-context 32 il:pointer) (edit-context 34 il:pointer) (edit-context 36 il:pointer) (edit-context 38 il:pointer) (edit-context 40 il:pointer) (edit-context 42 il:pointer) (edit-context 42 (il:flagbits . 0)) (edit-context 44 il:pointer) (edit-context 46 il:pointer) (edit-context 48 il:pointer) (edit-context 50 il:pointer) (edit-context 52 il:pointer) (edit-context 54 il:pointer) (edit-context 56 il:pointer) (edit-context 58 il:pointer) (edit-context 60 il:pointer) (edit-context 62 il:pointer) (edit-context 64 il:pointer) (edit-context 66 il:pointer) (edit-context 68 il:fullxpointer) (edit-context 70 il:pointer) (edit-context 72 il:fullxpointer) (edit-context 74 (il:bits . 15)) (edit-context 76 il:fullxpointer) (edit-context 78 il:fullxpointer) (edit-context 80 il:pointer) (edit-context 82 il:pointer) (edit-context 84 il:pointer) (edit-context 86 il:pointer) (edit-context 88 il:pointer) (edit-context 90 il:pointer) (edit-context 92 il:pointer) (edit-context 94 il:pointer) (edit-context 96 il:pointer) (edit-context 98 il:pointer) (edit-context 100 il:pointer) (edit-context 102 il:pointer) (edit-context 104 il:fullxpointer) (edit-context 106 il:fullxpointer) (edit-context 108 il:pointer) (edit-context 110 il:pointer) (edit-context 112 il:pointer) (edit-context 114 il:pointer) (edit-context 116 il:pointer))) (quote 118)) + +(il:/declaredatatype (quote edit-env) (quote (il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer)) (quote ((edit-env 0 il:pointer) (edit-env 2 il:pointer) (edit-env 4 il:pointer) (edit-env 6 il:pointer) (edit-env 8 il:pointer) (edit-env 10 il:pointer) (edit-env 12 il:pointer) (edit-env 14 il:pointer) (edit-env 16 il:pointer) (edit-env 18 il:pointer) (edit-env 20 il:pointer) (edit-env 22 il:pointer) (edit-env 24 il:pointer) (edit-env 26 il:pointer) (edit-env 28 il:pointer) (edit-env 30 il:pointer) (edit-env 32 il:pointer) (edit-env 34 il:pointer) (edit-env 36 il:pointer) (edit-env 38 il:pointer) (edit-env 40 il:pointer) (edit-env 42 il:pointer) (edit-env 44 il:pointer) (edit-env 46 il:pointer))) (quote 48)) + +(il:/declaredatatype (quote edit-node) (quote (il:fullxpointer il:pointer il:pointer il:fullxpointer il:word il:word il:pointer il:pointer il:fullxpointer il:pointer il:word il:word il:word il:word il:flag il:pointer il:pointer il:pointer il:pointer)) (quote ((edit-node 0 il:fullxpointer) (edit-node 2 il:pointer) (edit-node 4 il:pointer) (edit-node 6 il:fullxpointer) (edit-node 8 (il:bits . 15)) (edit-node 9 (il:bits . 15)) (edit-node 10 il:pointer) (edit-node 12 il:pointer) (edit-node 14 il:fullxpointer) (edit-node 16 il:pointer) (edit-node 18 (il:bits . 15)) (edit-node 19 (il:bits . 15)) (edit-node 20 (il:bits . 15)) (edit-node 21 (il:bits . 15)) (edit-node 16 (il:flagbits . 0)) (edit-node 22 il:pointer) (edit-node 24 il:pointer) (edit-node 26 il:pointer) (edit-node 28 il:pointer))) (quote 30)) + +(il:/declaredatatype (quote edit-node-type) (quote (il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer)) (quote ((edit-node-type 0 il:pointer) (edit-node-type 2 il:pointer) (edit-node-type 4 il:pointer) (edit-node-type 6 il:pointer) (edit-node-type 8 il:pointer) (edit-node-type 10 il:pointer) (edit-node-type 12 il:pointer) (edit-node-type 14 il:pointer) (edit-node-type 16 il:pointer) (edit-node-type 18 il:pointer) (edit-node-type 20 il:pointer) (edit-node-type 22 il:pointer) (edit-node-type 24 il:pointer) (edit-node-type 26 il:pointer) (edit-node-type 28 il:pointer) (edit-node-type 30 il:pointer) (edit-node-type 32 il:pointer) (edit-node-type 34 il:pointer))) (quote 36)) + +(il:/declaredatatype (quote edit-point) (quote (il:fullxpointer il:pointer il:pointer il:pointer il:fullxpointer il:pointer il:pointer)) (quote ((edit-point 0 il:fullxpointer) (edit-point 2 il:pointer) (edit-point 4 il:pointer) (edit-point 6 il:pointer) (edit-point 8 il:fullxpointer) (edit-point 10 il:pointer) (edit-point 12 il:pointer))) (quote 14)) + +(il:/declaredatatype (quote edit-selection) (quote (il:fullxpointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:fullxpointer il:pointer il:fullxpointer il:pointer il:pointer il:pointer)) (quote ((edit-selection 0 il:fullxpointer) (edit-selection 2 il:pointer) (edit-selection 4 il:pointer) (edit-selection 6 il:pointer) (edit-selection 8 il:pointer) (edit-selection 10 il:pointer) (edit-selection 12 il:pointer) (edit-selection 14 il:fullxpointer) (edit-selection 16 il:pointer) (edit-selection 18 il:fullxpointer) (edit-selection 20 il:pointer) (edit-selection 22 il:pointer) (edit-selection 24 il:pointer))) (quote 26)) + +(il:/declaredatatype (quote gap) (quote (il:pointer)) (quote ((gap 0 il:pointer))) (quote 2)) + +(il:/declaredatatype (quote line-block) (quote (il:fullxpointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer il:pointer)) (quote ((line-block 0 il:fullxpointer) (line-block 2 il:pointer) (line-block 4 il:pointer) (line-block 6 il:pointer) (line-block 8 il:pointer) (line-block 10 il:pointer) (line-block 12 il:pointer) (line-block 14 il:pointer) (line-block 16 il:pointer))) (quote 18)) + +(il:/declaredatatype (quote line-start) (quote (il:fullxpointer il:fullxpointer il:fullxpointer il:word il:word il:word il:word il:word il:pointer il:word il:pointer il:word il:word)) (quote ((line-start 0 il:fullxpointer) (line-start 2 il:fullxpointer) (line-start 4 il:fullxpointer) (line-start 6 (il:bits . 15)) (line-start 7 (il:bits . 15)) (line-start 8 (il:bits . 15)) (line-start 9 (il:bits . 15)) (line-start 10 (il:bits . 15)) (line-start 12 il:pointer) (line-start 11 (il:bits . 15)) (line-start 14 il:pointer) (line-start 16 (il:bits . 15)) (line-start 17 (il:bits . 15)))) (quote 18)) + +(il:/declaredatatype (quote list-format) (quote (il:pointer il:pointer il:pointer il:pointer il:pointer)) (quote ((list-format 0 il:pointer) (list-format 2 il:pointer) (list-format 4 il:pointer) (list-format 6 il:pointer) (list-format 8 il:pointer))) (quote 10)) + +(il:/declaredatatype (quote string-item) (quote (il:pointer il:word il:fullxpointer il:flag)) (quote ((string-item 0 il:pointer) (string-item 2 (il:bits . 15)) (string-item 4 il:fullxpointer) (string-item 3 (il:flagbits . 0)))) (quote 6)) + +(il:/declaredatatype (quote weak-link) (quote (il:fullxpointer)) (quote ((weak-link 0 il:fullxpointer))) (quote 2)) + + + +(il:* il:|;;| "interface globalvars") + +(il:declare\: il:doeval@compile il:dontcopy + + +(il:globalvars convert-upgrade keep-window-region contexts lisp-edit-environment list-formats-table pretty-print-env regions) +) + + + +(il:* il:|;;| "shared globalvars") + +(il:declare\: il:doeval@compile il:dontcopy + + +(il:globalvars il:boldfont il:clispfont il:commentflg il:commentfont il:defaultfont il:promptwindow il:italicfont args-gap atom-caret basic-gap body-gap button-string button-string-node structure-caret clisp-indent-words clisp-program-words command-table-spec list-parse-info terminal-table temp-point temp-selection type-clisp type-comment type-comment-word type-dotlist type-gap type-list type-litatom type-quote type-root type-string type-unknown types args-bitmap body-bitmap gap-bitmap) +) + + + +(il:* il:|;;| "window file globalvars") + +(il:declare\: il:doeval@compile il:dontcopy + + +(il:globalvars titled-icon selection-pending? pending-selection initial-selection scratch-selection pending-caret pending-last-x pending-last-y pending-type pending-shift last-move-clock button-string-node) +) + + + +(il:* il:|;;| "command file globalvars") + +(il:declare\: il:doeval@compile il:dontcopy + + +(il:globalvars menus menu-description mutate-candidate package-candidate printbase-candidate find-candidate substitute-candidate) +) + + + +(il:* il:|;;| "random constants") + +(il:declare\: il:eval@compile + +(il:rpaq editor-name "SEdit") + +(il:rpaqq il:micasperpt 35.27778) + +(il:rpaqq quote-wrapper-list (quote quote il:bquote il:bquote il:comma il:\\\, comma-at il:\\\,@ comma-dot il:\\\,. function function)) + + +(il:constants (editor-name "SEdit") (il:micasperpt 35.27778) (quote-wrapper-list (quote (quote quote il:bquote il:bquote il:comma il:\\\, comma-at il:\\\,@ comma-dot il:\\\,. function function)))) +) + + + +(il:* il:|;;| "random macros") + +(il:declare\: il:eval@compile + +(il:putprops get-prompt-window il:macro ((context) (il:getpromptwindow (il:|fetch| display-window il:|of| context)))) + +(il:putprops eval-in-process il:macro (nil (let* ((process (if (eq (il:processprop (il:this.process) (quote il:name)) (quote il:mouse)) (il:tty.process) (il:this.process))) (procform (il:processprop process (quote il:form)))) (cond ((eq (car procform) (quote edit1)) (il:|fetch| eval-in-process il:|of| (cadadr procform))) (t process))))) + +(il:putprops lookup-command il:macro ((char table) (gethash char table))) + +(il:putprops quote-wrapper il:macro (type (cond ((and (il:listp (car type)) (eq (caar type) (quote quote))) (if (il:listp (cadar type)) (il:kwote (il:|for| w il:|in| (cadar type) il:|collect| (il:listget quote-wrapper-list w))) (il:kwote (il:listget quote-wrapper-list (cadar type))))) (t (il:bquote (il:listget quote-wrapper-list (il:\\\, (car type)))))))) + +(il:putprops quote-wrapper-name il:macro ((type) (il:listget (il:constant (il:reverse quote-wrapper-list)) type))) + +(il:putprops repaint-new-line il:macro (il:openlambda (line) (when (il:ilessp (il:|fetch| next-line-y il:|of| (car line)) (il:|fetch| window-top il:|of| context)) (repaint context (il:|fetch| indent il:|of| (car line)) (il:|fetch| base-line-y il:|of| (car line)) (cdr line) (il:|fetch| linear-pointer il:|of| context)) (when (il:ilessp (il:|fetch| next-line-y il:|of| (car line)) (il:|fetch| window-bottom il:|of| context)) (il:|replace| below? il:|of| context il:|with| t))))) + +(il:putprops reset-control-variables il:macro ((context) (when (compiling-post-koto) (il:setq *package* (il:fetch package il:of context)) (il:setq *print-array* nil) (il:setq *print-base* (il:fetch print-base il:of context)) (il:setq *print-case* (il:fetch print-case il:of context)) (il:setq *print-escape* t) (il:setq *print-gensym* t) (il:setq *print-radix* nil)))) + +(il:putprops select-comment-indent il:macro ((key level-1-indent level-2-indent level-3-indent) (il:selectq key (1 level-1-indent) (2 level-2-indent) ((3 4 5) level-3-indent) (il:shouldnt "unexpected comment level")))) + +(il:putprops set-comment-positions il:macro ((comment-start-x comment-indent form-indent paren-width node context) (cond ((il:igeq (il:iplus form-indent (il:|fetch| comment-width il:|of| context)) (il:|fetch| right-margin il:|of| node)) (il:setq comment-start-x (il:iplus (il:|fetch| start-x il:|of| node) paren-width)) (il:setq comment-indent comment-start-x)) (t (il:setq comment-start-x (il:idifference (il:|fetch| right-margin il:|of| node) (il:|fetch| comment-width il:|of| context))) (il:setq comment-indent (il:iplus comment-start-x (il:|fetch| comment-separation il:|of| context))))))) + +(il:putprops set-selection-nowhere il:macro ((selection) (il:|replace| select-node il:|of| selection il:|with| nil))) +) + + + +(il:* il:|;;| "kernel macros") + + +(defmacro create-weak-link (dest) (il:bquote (il:|create| weak-link destination il:_ (il:\\\, dest)))) +(il:declare\: il:eval@compile + +(il:putprops advance il:macro ((width) (il:|add| (il:|fetch| current-x il:|of| context) width))) + +(il:putprops close-open-node il:macro ((context) (when (il:|fetch| open-node-changed? il:|of| context) (close-node context)))) + +(il:putprops dead-node? il:macro ((node) (eq 0 (il:|fetch| depth il:|of| node)))) + +(il:putprops end-undo-block il:macro (nil (collect-undo-block context))) + +(il:putprops escape-char il:macro ((read-table) (il:|fetch| (readtablep il:escapechar) il:|of| (or read-table *readtable*)))) + +(il:putprops eq-point-type il:macro ((point type) (let ((pointnode (il:|fetch| point-node il:|of| point))) (if (il:|type?| edit-selection pointnode) (eq (il:|fetch| node-type il:|of| (il:|fetch| select-node il:|of| pointnode)) type) (eq (il:|fetch| node-type il:|of| pointnode) type))))) + +(il:putprops next-linear il:macro ((context item) (and (il:listp (il:|fetch| linear-pointer il:|of| context)) (eq (car (il:|fetch| linear-pointer il:|of| context)) item)))) + +(il:putprops set-linear il:macro (il:openlambda (context new-lptr) (il:|replace| linear-pointer il:|of| context il:|with| new-lptr) (if (il:listp (il:|fetch| linear-prev il:|of| context)) (rplacd (il:|fetch| linear-prev il:|of| context) new-lptr) (il:|replace| linear-form il:|of| (il:|fetch| linear-prev il:|of| context) il:|with| new-lptr)))) + +(il:putprops start-undo-block il:macro (nil (il:|push| (il:|fetch| undo-list il:|of| context) nil))) + +(il:putprops step-linear il:macro ((context) (il:|replace| linear-pointer il:|of| context il:|with| (cdr (il:|replace| linear-prev il:|of| context il:|with| (il:|fetch| linear-pointer il:|of| context)))))) + +(il:putprops subnode il:macro (x (if (eq (car x) 1) (list (quote cadr) (list (quote il:fetch) (quote sub-nodes) (cadr x))) (list (quote cadr) (list (quote il:nth) (list (quote il:fetch) (quote sub-nodes) (cadr x)) (car x)))))) + +(il:putprops undo-by il:macro (info (list (quote il:push) (quote (il:|fetch| undo-list il:|of| context)) (list* (quote list) (il:kwote (car info)) (cdr info))))) + +(il:putprops zap-clisp-translation il:macro ((x) (and il:clisparray (il:puthash x nil il:clisparray)))) + +(il:putprops smash-using il:macro (x (il:|bind| (src il:_ (if (il:atom (caddr x)) (caddr x) (quote $$source))) dest (descr il:_ (il:getdescriptors (car x))) il:|first| (il:setq dest (list (quote il:replacefieldval) (list (quote quote) (car descr)) (cadr x) (list (quote il:fetchfield) (list (quote quote) (car descr)) src))) (il:setq descr (cdr descr)) il:|while| descr il:|do| (il:setq dest (list (quote il:freplacefieldval) (list (quote quote) (car descr)) dest (list (quote il:fetchfield) (list (quote quote) (car descr)) src))) (il:setq descr (cdr descr)) il:|finally| (when (not (il:atom (caddr x))) (il:setq dest (list (quote let) (list (list (quote $$source) (caddr x))) dest))) (return dest)))) + +(il:putprops il:half il:macro ((il:x) (il:lrsh il:x 1))) +) + + + +(il:* il:|;;| +"the symbols that come from interlisp, divided into those that conflict with CL symbols and those that don't. The SEDIT package declaration in the makefile-environment for all these files need not actually import any of these symbols, it just makes the functions easier to edit if you do cause then you don't need so many IL: prefixes." +) + + +(defparameter *il-cl-conflicts* (quote (il:*print-structure* il:* il:append il:apply il:assoc il:atom il:block il:character il:equal il:error il:floatp il:format il:function il:gethash il:if il:lambda il:length il:listp il:mapcar il:nth il:number il:numberp il:prin1 il:read il:reverse il:setq il:space il:stringp il:terpri))) + +(defparameter *il-imports* (quote (il:\" il:$$iterate il:$$lst1 il:$$out il:\( il:*display-editor* il:\, il:\. il:|.P2| il:/declaredatatype il:\; il:|;;| il:|;;;| il:? il:accessfns il:add.process il:add1 il:addspell il:addspellflg il:addtovar il:alist il:alists il:allocstring il:apply* il:ascent il:atm il:attachwindow il:await.event il:base il:bitblt il:bitmapheight il:bitmaps il:bitmapwidth il:bits il:bksysbuf il:blackshade il:bltshade il:bold il:boldfont il:bottom il:box il:bquote il:bs il:buttoneventfn il:buttons il:c il:caseinsensitive il:ccodep il:changename il:changeoffsetflg il:charcode il:chardelete il:charwidth il:chcon1 il:clearbuf il:clearw il:clisp\: il:clisparray il:clispfont il:clisptran il:clispword il:clock il:closefn il:closew il:column il:columnspace il:comma il:commentflg il:commentfont il:coms il:comtail il:concat il:concatlist il:constant il:constants il:control il:copy il:copyall il:copyright il:copytermtable il:cr il:create il:create.event il:create.monitorlock il:createregion il:createw il:ctrl il:ctrlv il:cursorcreate il:datatype il:date il:datum il:declarations\: il:declare\: il:defaultfont il:defineq il:del il:descent il:docopy il:doeval@compile il:don\'t il:dontcopy il:donteval@load il:dontwait il:dowindowcom il:dremove il:dreverse il:dsp il:dspclippingregion il:dspfont il:dsplinefeed il:dsprightmargin il:dspxoffset il:dspxposition il:dspyoffset il:|Definition-for-EDITDATE| il:|Definition-for-EDITE| il:|Definition-for-EDITL| il:e il:echomode il:edit il:editchanges il:editferror il:editgetd il:editmacros il:editmode il:environment il:eol il:eqmemb il:ersetq il:esc il:escape il:escapechar il:eval@compile il:evalv il:expandfn il:expandregionfn il:expandw il:expr il:extent il:fcharacter il:fetchfield il:filecreated il:filemap il:filepkgflg il:files il:filesload il:filetype il:find.process il:fixeditdate il:fixp il:fixr il:flag il:flagbits il:flashwindow il:flength il:fm.changelabel il:fm.changestate il:fm.dontreshape il:fm.edititem il:fm.getitem il:fm.itemprop il:fm.resetmenu il:fmemb il:fn il:fns il:font il:fontcreate il:fontprop il:form il:forword il:freemenu il:freplacefieldval il:fullxpointer il:functions il:gacha il:getd il:getdef il:getdescriptors il:getpromptwindow il:getprop il:getproplist il:getregion il:getsyntax il:globalvars il:group il:half il:height il:heightifwindow il:helvetica il:icon il:iconwindow il:id il:idifference il:ifword il:igeq il:igreaterp il:ileq il:ilessp il:imax il:imin il:iminus il:in/scroll/bar? il:innerescquote il:infohook il:initrecords il:initvars il:input il:insidep il:interpress il:invert il:iplus il:iquotient il:italicfont il:item il:items il:itemwidth il:itimes il:keyaction il:keyactiontable il:keyboardstream il:keydownp il:kwote il:l il:l-case il:label il:lastmousestate il:lastmousex il:lastmousey il:lconc il:left il:leftbracket il:leftparen il:leq il:linedelete il:links il:listget il:listput il:litatom il:localclose il:localvars il:lrsh il:macro il:macros il:mainwindow il:makefile-environment il:markaschanged il:markaschangedfns il:mask il:maxwidth il:memb il:menu il:menufont il:menuoffset il:mess il:micasperpt il:middle il:mkstring il:mouse il:mouseconfirm il:mousestate il:move il:moveto il:multescapechar il:multiple-escape il:name il:nchars il:nconc1 il:neq il:nill il:nlambda il:nlistp il:nlsetq il:nobind il:none il:notify.event il:nthcharcode il:obtain.monitorlock il:offst il:openlambda il:openstringstream il:openwp il:p il:packagedelim il:paint il:pointer il:prettycomprint il:prin2 il:process il:process.apply il:process.eval il:process.evalv il:processp il:processprop il:proctypeahead il:promptforword il:promptwindow il:prop il:proplst il:props il:putd il:putdef il:puthash il:putprop il:putprops il:quotient il:readcode il:readp il:readsa il:record il:records il:recordtran il:redisplayw il:region il:rejectmaincoms il:release.monitorlock il:relmoveto il:repaintfn il:replacefieldval il:repositionattachedwindows il:resetlst il:resetsave il:resetvar il:reshapefn il:restartable il:retfrom il:retype il:right il:rightbracket il:rightbuttonfn il:rightparen il:rowspace il:rpaq il:rpaq? il:rpaqq il:rplcharcode il:rplnode2 il:rplstring il:scroll.handler il:scrollbyrepaintfn il:scrollextentuse il:scrollfn il:scrollw il:selcharq il:selectedfn il:selectq il:seprchar il:setfs il:setinterrupt il:setproplist il:setsyntax il:settermtable il:shapew il:shift il:shiftdownp il:shouldnt il:shrinkfn il:smallp il:smartarglist il:sp il:specvars il:spellfile il:state il:stkpos il:strequal il:stringdelim il:stringwidth il:strpos il:sub1 il:substring il:sysrecords il:systemreclst il:tab il:table il:tail il:tconc il:tedit.insert il:tedit.paralooks il:this.process il:times il:title il:titledicon il:titlediconw il:titlereg il:top il:totopw il:tty.process il:tty.processp il:tty/editdate il:tty/edite il:tty/editl il:tty\: il:ttydisplaystream il:ttyexitfn il:typename il:u-case il:untilmousestate il:up il:usedfree il:variables il:vars il:vartype il:wait.for.tty il:whiteshade il:width il:window il:windowaddprop il:windowentryfn il:windowprop il:windowregion il:with.monitor il:word il:worddelete il:wxoffset il:wyoffset il:x il:y il:[ il:\\\, il:\\\,. il:\\\,@ il:\\addbase il:\\background il:\\blt il:\\bltchar il:\\caret.create il:\\caret.down il:\\caret.flash? il:\\defaultkeyaction il:\\dtest il:\\getbase il:\\getsysbuf il:\\keyboard.stream il:\\linebuf.ofd il:\\putbase il:\\savevmbackground il:\\syncode il:] il:^ il:_ il:add il:always il:as il:bind il:by il:change il:|changes| il:collect il:count il:create il:|date:| il:do il:eachtime il:else il:elseif il:fetch il:ffetch il:finally il:first il:for il:freplace il:from when il:in il:instring il:join il:largest il:never il:of il:old il:on il:outof il:pop il:|previous| il:|printout| il:push il:pushnew il:repeatuntil il:repeatwhile il:replace il:smallest il:sum il:then il:thereis il:to il:|to:| il:type? il:unless il:until il:using il:when il:where il:while il:with il:{ il:}))) + + + +(il:* il:|;;| "and a little reminder:") + + +(il:|printout| t t "EXPORTS.ALL must be loaded to compile SEdit" t) + +(il:|printout| t t "SEDIT-ACCESS must be REMADE NEW if you change a record" t) +(il:putprops il:sedit-decls il:copyright ("Xerox Corporation" 1987 1988)) +(il:declare\: il:dontcopy + (il:filemap (nil))) +il:stop diff --git a/lispusers/MIGRATION/SEDIT-DECLS.LCOM b/lispusers/MIGRATION/SEDIT-DECLS.LCOM new file mode 100644 index 00000000..79ec2279 --- /dev/null +++ b/lispusers/MIGRATION/SEDIT-DECLS.LCOM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE (DEFPACKAGE SEDIT (USE LISP XCL))) (IL:FILECREATED "19-Jan-93 19:57:14" ("compiled on " IL:|{DSK}local>src>tape>MIGRATION>SEDIT-DECLS.;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 "18-Apr-88 13:01:03" IL:{ERIS}SOURCES>SEDIT-DECLS.\;21 32113 IL:|changes| IL:|to:| (IL:VARS IL:SEDIT-DECLSCOMS) IL:|previous| IL:|date:| "13-Apr-88 17:22:16" IL:{ERIS}SOURCES>SEDIT-DECLS.\;20) (IL:PRETTYCOMPRINT IL:SEDIT-DECLSCOMS) (IL:RPAQQ IL:SEDIT-DECLSCOMS ((IL:PROP IL:FILETYPE IL:SEDIT-DECLS) (IL:PROP IL:MAKEFILE-ENVIRONMENT IL:SEDIT-DECLS) (IL:* IL:|;;;| "This file is for declaring things which are shared among sedit files. This file is loaded at compile time by each sedit file, but the contents of this file are not copied into any of the compiled files. The RECORDS declarations are here, and they are INITRECORDed and SYSRECORDed in SEDIT-ACCESS. If you change a record, make sure sedit-access gets remade NEW. All GLOBALVARS declarations are done here, because they're needed at compile time, but the actual variable declarations are done in the appropriate file. Constants and Macros are declared here only if they are shared among files; otherwise they can remain in the appropriate file. " ) (IL:RECORDS BROKEN-ATOM EDIT-CONTEXT EDIT-ENV EDIT-NODE EDIT-NODE-TYPE EDIT-POINT EDIT-SELECTION GAP LINE-BLOCK LINE-START LIST-FORMAT OPEN-STRING STRING-ITEM WEAK-LINK) (IL:* IL:|;;| "interface globalvars") (IL:GLOBALVARS CONVERT-UPGRADE KEEP-WINDOW-REGION CONTEXTS LISP-EDIT-ENVIRONMENT LIST-FORMATS-TABLE PRETTY-PRINT-ENV REGIONS) (IL:* IL:|;;| "shared globalvars") (IL:GLOBALVARS IL:BOLDFONT IL:CLISPFONT IL:COMMENTFLG IL:COMMENTFONT IL:DEFAULTFONT IL:PROMPTWINDOW IL:ITALICFONT ARGS-GAP ATOM-CARET BASIC-GAP BODY-GAP BUTTON-STRING BUTTON-STRING-NODE STRUCTURE-CARET CLISP-INDENT-WORDS CLISP-PROGRAM-WORDS COMMAND-TABLE-SPEC LIST-PARSE-INFO TERMINAL-TABLE TEMP-POINT TEMP-SELECTION TYPE-CLISP TYPE-COMMENT TYPE-COMMENT-WORD TYPE-DOTLIST TYPE-GAP TYPE-LIST TYPE-LITATOM TYPE-QUOTE TYPE-ROOT TYPE-STRING TYPE-UNKNOWN TYPES ARGS-BITMAP BODY-BITMAP GAP-BITMAP) (IL:* IL:|;;| "window file globalvars") (IL:GLOBALVARS TITLED-ICON SELECTION-PENDING? PENDING-SELECTION INITIAL-SELECTION SCRATCH-SELECTION PENDING-CARET PENDING-LAST-X PENDING-LAST-Y PENDING-TYPE PENDING-SHIFT LAST-MOVE-CLOCK BUTTON-STRING-NODE) (IL:* IL:|;;| "command file globalvars") ( IL:GLOBALVARS MENUS MENU-DESCRIPTION MUTATE-CANDIDATE PACKAGE-CANDIDATE PRINTBASE-CANDIDATE FIND-CANDIDATE SUBSTITUTE-CANDIDATE) (IL:* IL:|;;| "random constants") (IL:CONSTANTS (EDITOR-NAME "SEdit") (IL:MICASPERPT 35.27778) (QUOTE-WRAPPER-LIST (QUOTE (QUOTE QUOTE IL:BQUOTE IL:BQUOTE IL:COMMA IL:\\\, COMMA-AT IL:\\\,@ COMMA-DOT IL:\\\,. FUNCTION FUNCTION)))) (IL:* IL:|;;| "random macros") ( IL:MACROS GET-PROMPT-WINDOW EVAL-IN-PROCESS LOOKUP-COMMAND QUOTE-WRAPPER QUOTE-WRAPPER-NAME REPAINT-NEW-LINE RESET-CONTROL-VARIABLES SELECT-COMMENT-INDENT SET-COMMENT-POSITIONS SET-SELECTION-NOWHERE) (IL:* IL:|;;| "kernel macros") (IL:FUNCTIONS CREATE-WEAK-LINK) (IL:MACROS ADVANCE CLOSE-OPEN-NODE DEAD-NODE? END-UNDO-BLOCK ESCAPE-CHAR EQ-POINT-TYPE NEXT-LINEAR SET-LINEAR START-UNDO-BLOCK STEP-LINEAR SUBNODE UNDO-BY ZAP-CLISP-TRANSLATION SMASH-USING IL:HALF) (IL:* IL:|;;| "the symbols that come from interlisp, divided into those that conflict with CL symbols and those that don't. The SEDIT package declaration in the makefile-environment for all these files need not actually import any of these symbols, it just makes the functions easier to edit if you do cause then you don't need so many IL: prefixes." ) (IL:VARIABLES *IL-CL-CONFLICTS* *IL-IMPORTS*) (IL:* IL:|;;| "and a little reminder:") (IL:P ( IL:|printout| T T "EXPORTS.ALL must be loaded to compile SEdit" T) (IL:|printout| T T "SEDIT-ACCESS must be REMADE NEW if you change a record" T)))) (IL:PUTPROPS IL:SEDIT-DECLS IL:FILETYPE :COMPILE-FILE) (IL:PUTPROPS IL:SEDIT-DECLS IL:MAKEFILE-ENVIRONMENT (:READTABLE "XCL" :PACKAGE (DEFPACKAGE IL:SEDIT ( :USE IL:LISP IL:XCL)))) (IL:DATATYPE BROKEN-ATOM (ATOM-CHARS)) (IL:DATATYPE EDIT-CONTEXT (ENVIRONMENT PROFILE EVAL-FN EVAL-IN-PROCESS CONTEXT-LOCK COMPLETION-EVENT EDIT-TYPE ICON-TITLE EDIT-OPTIONS COMMENT-WIDTH COMMENT-SEPARATION FIND-CANDIDATE SUBSTITUTE-CANDIDATE DISPLAY-WINDOW WINDOW-LEFT WINDOW-BOTTOM WINDOW-RIGHT WINDOW-TOP ROOT ROOT-CHANGED-FN COMPLETION-FN CHANGED-STRUCTURE? (DONT-COLLECT-CHANGES? IL:FLAG) CHANGED-NODES OPEN-NODE-CHANGED? OPEN-NODE OPEN-NODE-INFO ATOM-STARTED ATOM-STARTED-UNDO-POINTER UNDO-LIST UNDO-UNDO-LIST CARET CARET-POINT SELECTION SELECTION-DISPLAYED? (CURRENT-NODE IL:FULLXPOINTER) CURRENT-X (CURRENT-LINE IL:FULLXPOINTER) (LAST-LINEARIZED-SUB-NODE-INDEX IL:WORD) (LINEAR-POINTER IL:FULLXPOINTER) (LINEAR-PREV IL:FULLXPOINTER ) LAST-MOUSE-X LAST-MOUSE-Y LAST-MOUSE-TYPE \\X \\Y \\Z \\T FIRST-BLOCK CURRENT-BLOCK MATCHING? BELOW? VISIBLE? (REPAINT-START IL:FULLXPOINTER) (REPAINT-LINE IL:FULLXPOINTER) REPAINT-X RELINEARIZATION-TIME-STAMP SHIFT-Y SHIFT-DOWN SHIFT-RIGHT) CHANGED-NODES IL:_ (CONS)) (IL:DATATYPE EDIT-ENV (PARSE-INFO PARSE-INFO-UNKNOWN USER-DATA DEFAULT-FONT ITALIC-FONT KEYWORD-FONT COMMENT-FONT BROKEN-ATOM-FONT SPACE-WIDTH DEFAULT-LINE-SKIP EM-WIDTH INDENT-BASE INDENT-STEP MAX-WIDTH COMMENT-WIDTH-PERCENT INIT-COMMENT-SEPARATION LPAREN-STRING RPAREN-STRING DOT-STRING QUOTE-STRING COMMENT-STRING COMMAND-TABLE DEFAULT-CHAR-HANDLER HELP-MENU)) (IL:DATATYPE EDIT-NODE ((NODE-TYPE IL:FULLXPOINTER) FORMAT UNASSIGNED (SUPER-NODE IL:FULLXPOINTER) ( DEPTH IL:WORD) (SUB-NODE-INDEX IL:WORD) STRUCTURE SUB-NODES (LINEAR-THREAD IL:FULLXPOINTER) LINEAR-FORM (START-X IL:WORD) (RIGHT-MARGIN IL:WORD) (PREFERRED-WIDTH IL:WORD) (ACTUAL-WIDTH IL:WORD) (CHANGED? IL:FLAG) INLINE-WIDTH ACTUAL-LLENGTH FIRST-LINE LAST-LINE) (IL:ACCESSFNS (INLINE? (EQ ( IL:|fetch| FIRST-LINE IL:|of| IL:DATUM) (IL:|fetch| LAST-LINE IL:|of| IL:DATUM)))) FORMAT IL:_ (QUOTE NOT-YET-ASSIGNED)) (IL:DATATYPE EDIT-NODE-TYPE (NAME ASSIGN-FORMAT COMPUTE-FORMAT-VALUES LINEARIZE SUB-NODE-CHANGED SET-POINT COMPUTE-POINT-POSITION COMPUTE-SELECTION-POSITION SET-SELECTION GROW-SELECTION SELECT-SEGMENT INSERT DELETE COPY-STRUCTURE COPY-SELECTION STRINGIFY BACK-SPACE CLOSE-NODE)) (IL:DATATYPE EDIT-POINT ((POINT-NODE IL:FULLXPOINTER) POINT-INDEX POINT-TYPE POINT-X (POINT-LINE IL:FULLXPOINTER) POINT-STRING POINT-OFFSET)) (IL:DATATYPE EDIT-SELECTION ((SELECT-NODE IL:FULLXPOINTER) SELECT-START SELECT-END SELECT-TYPE DELETE-OK? PENDING-DELETE? SELECT-START-X (SELECT-START-LINE IL:FULLXPOINTER) SELECT-END-X ( SELECT-END-LINE IL:FULLXPOINTER) SELECT-STRING SELECT-START-OFFSET SELECT-END-OFFSET)) (IL:DATATYPE GAP (LINEAR-ITEM)) (IL:DATATYPE LINE-BLOCK ((BLOCK-START IL:FULLXPOINTER) BLOCK-NEW-X BLOCK-WIDTH NEXT-BLOCK BITS? BLOCK-X BLOCK-BASE-LINE BLOCK-ASCENT BLOCK-DESCENT)) (IL:DATATYPE LINE-START ((NEXT-LINE IL:FULLXPOINTER) (PREV-LINE IL:FULLXPOINTER) (NODE IL:FULLXPOINTER ) (LINE-ASCENT IL:WORD) (LINE-DESCENT IL:WORD) (LINE-SKIP IL:WORD) (LINE-LENGTH IL:WORD) (INDENT IL:WORD ) YCOORD (CACHE-TIME IL:WORD) CACHED-Y (CACHED-ASCENT IL:WORD) (CACHED-DESCENT IL:WORD)) (IL:ACCESSFNS (LINE-HEIGHT (IL:IPLUS (IL:FETCH LINE-SKIP IL:OF IL:DATUM) (IL:FETCH LINE-ASCENT IL:OF IL:DATUM) ( IL:FETCH LINE-DESCENT IL:OF IL:DATUM)))) (IL:ACCESSFNS (BASE-LINE-Y (IL:IDIFFERENCE (IL:ADD1 (IL:FETCH YCOORD IL:OF IL:DATUM)) (IL:IPLUS (IL:FETCH LINE-SKIP IL:OF IL:DATUM) (IL:FETCH LINE-ASCENT IL:OF IL:DATUM))))) (IL:ACCESSFNS (NEXT-LINE-Y (IL:IDIFFERENCE (IL:FETCH YCOORD IL:OF IL:DATUM) (IL:FETCH LINE-HEIGHT IL:OF IL:DATUM)))) (IL:ACCESSFNS (OLD-TOP (IF (EQ (IL:FETCH CACHE-TIME IL:OF IL:DATUM) ( IL:|fetch| RELINEARIZATION-TIME-STAMP IL:|of| CONTEXT)) (IL:SUB1 (IL:IPLUS (IL:FETCH CACHED-Y IL:OF IL:DATUM) (IL:FETCH CACHED-ASCENT IL:OF IL:DATUM))) (IL:FETCH YCOORD IL:OF IL:DATUM)))) (IL:ACCESSFNS (OLD-BOTTOM (IF (EQ (IL:FETCH CACHE-TIME IL:OF IL:DATUM) (IL:|fetch| RELINEARIZATION-TIME-STAMP IL:|of| CONTEXT)) (IL:IDIFFERENCE (IL:FETCH CACHED-Y IL:OF IL:DATUM) (IL:FETCH CACHED-DESCENT IL:OF IL:DATUM) ) (IL:ADD1 (IL:FETCH NEXT-LINE-Y IL:OF IL:DATUM)))))) (IL:DATATYPE LIST-FORMAT (LIST-FORMATS LIST-INLINE? LIST-PFORMAT LIST-MFORMAT LIST-SUBLISTS) ( IL:ACCESSFNS (NON-STANDARD? (NULL (IL:|fetch| LIST-FORMATS IL:|of| IL:DATUM)))) (IL:ACCESSFNS ( SET-FORMAT-LIST (IL:|fetch| LIST-INLINE? IL:|of| IL:DATUM))) (IL:ACCESSFNS (CFVLIST (IL:|fetch| LIST-PFORMAT IL:|of| IL:DATUM))) (IL:ACCESSFNS (LINEARIZE-LIST (IL:|fetch| LIST-MFORMAT IL:|of| IL:DATUM ))) LIST-SUBLISTS IL:_ NIL) (IL:RECORD OPEN-STRING (REAL-LENGTH SUBSTRING . BUFFER-STRING)) (IL:DATATYPE STRING-ITEM (STRING (WIDTH IL:WORD) (FONT IL:FULLXPOINTER) (PRIN-2? IL:FLAG))) (IL:DATATYPE WEAK-LINK ((DESTINATION IL:FULLXPOINTER))) (IL:/DECLAREDATATYPE (QUOTE BROKEN-ATOM) (QUOTE (IL:POINTER)) (QUOTE ((BROKEN-ATOM 0 IL:POINTER))) ( QUOTE 2)) (IL:/DECLAREDATATYPE (QUOTE EDIT-CONTEXT) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:FLAG IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:FULLXPOINTER IL:WORD IL:FULLXPOINTER IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((EDIT-CONTEXT 0 IL:POINTER) (EDIT-CONTEXT 2 IL:POINTER) ( EDIT-CONTEXT 4 IL:POINTER) (EDIT-CONTEXT 6 IL:POINTER) (EDIT-CONTEXT 8 IL:POINTER) (EDIT-CONTEXT 10 IL:POINTER) (EDIT-CONTEXT 12 IL:POINTER) (EDIT-CONTEXT 14 IL:POINTER) (EDIT-CONTEXT 16 IL:POINTER) ( EDIT-CONTEXT 18 IL:POINTER) (EDIT-CONTEXT 20 IL:POINTER) (EDIT-CONTEXT 22 IL:POINTER) (EDIT-CONTEXT 24 IL:POINTER) (EDIT-CONTEXT 26 IL:POINTER) (EDIT-CONTEXT 28 IL:POINTER) (EDIT-CONTEXT 30 IL:POINTER) ( EDIT-CONTEXT 32 IL:POINTER) (EDIT-CONTEXT 34 IL:POINTER) (EDIT-CONTEXT 36 IL:POINTER) (EDIT-CONTEXT 38 IL:POINTER) (EDIT-CONTEXT 40 IL:POINTER) (EDIT-CONTEXT 42 IL:POINTER) (EDIT-CONTEXT 42 (IL:FLAGBITS . 0)) (EDIT-CONTEXT 44 IL:POINTER) (EDIT-CONTEXT 46 IL:POINTER) (EDIT-CONTEXT 48 IL:POINTER) ( EDIT-CONTEXT 50 IL:POINTER) (EDIT-CONTEXT 52 IL:POINTER) (EDIT-CONTEXT 54 IL:POINTER) (EDIT-CONTEXT 56 IL:POINTER) (EDIT-CONTEXT 58 IL:POINTER) (EDIT-CONTEXT 60 IL:POINTER) (EDIT-CONTEXT 62 IL:POINTER) ( EDIT-CONTEXT 64 IL:POINTER) (EDIT-CONTEXT 66 IL:POINTER) (EDIT-CONTEXT 68 IL:FULLXPOINTER) ( EDIT-CONTEXT 70 IL:POINTER) (EDIT-CONTEXT 72 IL:FULLXPOINTER) (EDIT-CONTEXT 74 (IL:BITS . 15)) ( EDIT-CONTEXT 76 IL:FULLXPOINTER) (EDIT-CONTEXT 78 IL:FULLXPOINTER) (EDIT-CONTEXT 80 IL:POINTER) ( EDIT-CONTEXT 82 IL:POINTER) (EDIT-CONTEXT 84 IL:POINTER) (EDIT-CONTEXT 86 IL:POINTER) (EDIT-CONTEXT 88 IL:POINTER) (EDIT-CONTEXT 90 IL:POINTER) (EDIT-CONTEXT 92 IL:POINTER) (EDIT-CONTEXT 94 IL:POINTER) ( EDIT-CONTEXT 96 IL:POINTER) (EDIT-CONTEXT 98 IL:POINTER) (EDIT-CONTEXT 100 IL:POINTER) (EDIT-CONTEXT 102 IL:POINTER) (EDIT-CONTEXT 104 IL:FULLXPOINTER) (EDIT-CONTEXT 106 IL:FULLXPOINTER) (EDIT-CONTEXT 108 IL:POINTER) (EDIT-CONTEXT 110 IL:POINTER) (EDIT-CONTEXT 112 IL:POINTER) (EDIT-CONTEXT 114 IL:POINTER ) (EDIT-CONTEXT 116 IL:POINTER))) (QUOTE 118)) (IL:/DECLAREDATATYPE (QUOTE EDIT-ENV) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((EDIT-ENV 0 IL:POINTER) (EDIT-ENV 2 IL:POINTER) (EDIT-ENV 4 IL:POINTER) (EDIT-ENV 6 IL:POINTER) (EDIT-ENV 8 IL:POINTER) (EDIT-ENV 10 IL:POINTER) (EDIT-ENV 12 IL:POINTER) (EDIT-ENV 14 IL:POINTER) (EDIT-ENV 16 IL:POINTER) (EDIT-ENV 18 IL:POINTER) (EDIT-ENV 20 IL:POINTER) (EDIT-ENV 22 IL:POINTER) (EDIT-ENV 24 IL:POINTER) (EDIT-ENV 26 IL:POINTER) (EDIT-ENV 28 IL:POINTER) (EDIT-ENV 30 IL:POINTER) (EDIT-ENV 32 IL:POINTER) (EDIT-ENV 34 IL:POINTER) (EDIT-ENV 36 IL:POINTER) (EDIT-ENV 38 IL:POINTER) (EDIT-ENV 40 IL:POINTER) (EDIT-ENV 42 IL:POINTER) (EDIT-ENV 44 IL:POINTER) (EDIT-ENV 46 IL:POINTER))) (QUOTE 48)) (IL:/DECLAREDATATYPE (QUOTE EDIT-NODE) (QUOTE (IL:FULLXPOINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:WORD IL:WORD IL:POINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:WORD IL:WORD IL:WORD IL:WORD IL:FLAG IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((EDIT-NODE 0 IL:FULLXPOINTER) (EDIT-NODE 2 IL:POINTER) (EDIT-NODE 4 IL:POINTER) (EDIT-NODE 6 IL:FULLXPOINTER) (EDIT-NODE 8 (IL:BITS . 15)) ( EDIT-NODE 9 (IL:BITS . 15)) (EDIT-NODE 10 IL:POINTER) (EDIT-NODE 12 IL:POINTER) (EDIT-NODE 14 IL:FULLXPOINTER) (EDIT-NODE 16 IL:POINTER) (EDIT-NODE 18 (IL:BITS . 15)) (EDIT-NODE 19 (IL:BITS . 15)) (EDIT-NODE 20 (IL:BITS . 15)) (EDIT-NODE 21 (IL:BITS . 15)) (EDIT-NODE 16 (IL:FLAGBITS . 0)) ( EDIT-NODE 22 IL:POINTER) (EDIT-NODE 24 IL:POINTER) (EDIT-NODE 26 IL:POINTER) (EDIT-NODE 28 IL:POINTER) )) (QUOTE 30)) (IL:/DECLAREDATATYPE (QUOTE EDIT-NODE-TYPE) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((EDIT-NODE-TYPE 0 IL:POINTER) ( EDIT-NODE-TYPE 2 IL:POINTER) (EDIT-NODE-TYPE 4 IL:POINTER) (EDIT-NODE-TYPE 6 IL:POINTER) ( EDIT-NODE-TYPE 8 IL:POINTER) (EDIT-NODE-TYPE 10 IL:POINTER) (EDIT-NODE-TYPE 12 IL:POINTER) ( EDIT-NODE-TYPE 14 IL:POINTER) (EDIT-NODE-TYPE 16 IL:POINTER) (EDIT-NODE-TYPE 18 IL:POINTER) ( EDIT-NODE-TYPE 20 IL:POINTER) (EDIT-NODE-TYPE 22 IL:POINTER) (EDIT-NODE-TYPE 24 IL:POINTER) ( EDIT-NODE-TYPE 26 IL:POINTER) (EDIT-NODE-TYPE 28 IL:POINTER) (EDIT-NODE-TYPE 30 IL:POINTER) ( EDIT-NODE-TYPE 32 IL:POINTER) (EDIT-NODE-TYPE 34 IL:POINTER))) (QUOTE 36)) (IL:/DECLAREDATATYPE (QUOTE EDIT-POINT) (QUOTE (IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:POINTER)) (QUOTE ((EDIT-POINT 0 IL:FULLXPOINTER) (EDIT-POINT 2 IL:POINTER ) (EDIT-POINT 4 IL:POINTER) (EDIT-POINT 6 IL:POINTER) (EDIT-POINT 8 IL:FULLXPOINTER) (EDIT-POINT 10 IL:POINTER) (EDIT-POINT 12 IL:POINTER))) (QUOTE 14)) (IL:/DECLAREDATATYPE (QUOTE EDIT-SELECTION) (QUOTE (IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((EDIT-SELECTION 0 IL:FULLXPOINTER) (EDIT-SELECTION 2 IL:POINTER) (EDIT-SELECTION 4 IL:POINTER) (EDIT-SELECTION 6 IL:POINTER) (EDIT-SELECTION 8 IL:POINTER) (EDIT-SELECTION 10 IL:POINTER ) (EDIT-SELECTION 12 IL:POINTER) (EDIT-SELECTION 14 IL:FULLXPOINTER) (EDIT-SELECTION 16 IL:POINTER) ( EDIT-SELECTION 18 IL:FULLXPOINTER) (EDIT-SELECTION 20 IL:POINTER) (EDIT-SELECTION 22 IL:POINTER) ( EDIT-SELECTION 24 IL:POINTER))) (QUOTE 26)) (IL:/DECLAREDATATYPE (QUOTE GAP) (QUOTE (IL:POINTER)) (QUOTE ((GAP 0 IL:POINTER))) (QUOTE 2)) (IL:/DECLAREDATATYPE (QUOTE LINE-BLOCK) (QUOTE (IL:FULLXPOINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER)) (QUOTE ((LINE-BLOCK 0 IL:FULLXPOINTER) ( LINE-BLOCK 2 IL:POINTER) (LINE-BLOCK 4 IL:POINTER) (LINE-BLOCK 6 IL:POINTER) (LINE-BLOCK 8 IL:POINTER) (LINE-BLOCK 10 IL:POINTER) (LINE-BLOCK 12 IL:POINTER) (LINE-BLOCK 14 IL:POINTER) (LINE-BLOCK 16 IL:POINTER))) (QUOTE 18)) (IL:/DECLAREDATATYPE (QUOTE LINE-START) (QUOTE (IL:FULLXPOINTER IL:FULLXPOINTER IL:FULLXPOINTER IL:WORD IL:WORD IL:WORD IL:WORD IL:WORD IL:POINTER IL:WORD IL:POINTER IL:WORD IL:WORD)) (QUOTE ((LINE-START 0 IL:FULLXPOINTER) (LINE-START 2 IL:FULLXPOINTER) (LINE-START 4 IL:FULLXPOINTER) (LINE-START 6 (IL:BITS . 15)) (LINE-START 7 (IL:BITS . 15)) (LINE-START 8 (IL:BITS . 15)) (LINE-START 9 (IL:BITS . 15)) ( LINE-START 10 (IL:BITS . 15)) (LINE-START 12 IL:POINTER) (LINE-START 11 (IL:BITS . 15)) (LINE-START 14 IL:POINTER) (LINE-START 16 (IL:BITS . 15)) (LINE-START 17 (IL:BITS . 15)))) (QUOTE 18)) (IL:/DECLAREDATATYPE (QUOTE LIST-FORMAT) (QUOTE (IL:POINTER IL:POINTER IL:POINTER IL:POINTER IL:POINTER )) (QUOTE ((LIST-FORMAT 0 IL:POINTER) (LIST-FORMAT 2 IL:POINTER) (LIST-FORMAT 4 IL:POINTER) ( LIST-FORMAT 6 IL:POINTER) (LIST-FORMAT 8 IL:POINTER))) (QUOTE 10)) (IL:/DECLAREDATATYPE (QUOTE STRING-ITEM) (QUOTE (IL:POINTER IL:WORD IL:FULLXPOINTER IL:FLAG)) (QUOTE ( (STRING-ITEM 0 IL:POINTER) (STRING-ITEM 2 (IL:BITS . 15)) (STRING-ITEM 4 IL:FULLXPOINTER) (STRING-ITEM 3 (IL:FLAGBITS . 0)))) (QUOTE 6)) (IL:/DECLAREDATATYPE (QUOTE WEAK-LINK) (QUOTE (IL:FULLXPOINTER)) (QUOTE ((WEAK-LINK 0 IL:FULLXPOINTER) )) (QUOTE 2)) (IL:RPAQ EDITOR-NAME "SEdit") (IL:RPAQQ IL:MICASPERPT 35.27778) (IL:RPAQQ QUOTE-WRAPPER-LIST (QUOTE QUOTE IL:BQUOTE IL:BQUOTE IL:COMMA IL:\\\, COMMA-AT IL:\\\,@ COMMA-DOT IL:\\\,. FUNCTION FUNCTION)) (IL:CONSTANTS (EDITOR-NAME "SEdit") (IL:MICASPERPT 35.27778) (QUOTE-WRAPPER-LIST (QUOTE (QUOTE QUOTE IL:BQUOTE IL:BQUOTE IL:COMMA IL:\\\, COMMA-AT IL:\\\,@ COMMA-DOT IL:\\\,. FUNCTION FUNCTION)))) (IL:PUTPROPS GET-PROMPT-WINDOW IL:MACRO ((CONTEXT) (IL:GETPROMPTWINDOW (IL:|fetch| DISPLAY-WINDOW IL:|of| CONTEXT)))) (IL:PUTPROPS EVAL-IN-PROCESS IL:MACRO (NIL (LET* ((PROCESS (IF (EQ (IL:PROCESSPROP (IL:THIS.PROCESS) ( QUOTE IL:NAME)) (QUOTE IL:MOUSE)) (IL:TTY.PROCESS) (IL:THIS.PROCESS))) (PROCFORM (IL:PROCESSPROP PROCESS (QUOTE IL:FORM)))) (COND ((EQ (CAR PROCFORM) (QUOTE EDIT1)) (IL:|fetch| EVAL-IN-PROCESS IL:|of| (CADADR PROCFORM))) (T PROCESS))))) (IL:PUTPROPS LOOKUP-COMMAND IL:MACRO ((CHAR TABLE) (GETHASH CHAR TABLE))) (IL:PUTPROPS QUOTE-WRAPPER IL:MACRO (TYPE (COND ((AND (IL:LISTP (CAR TYPE)) (EQ (CAAR TYPE) (QUOTE QUOTE))) (IF (IL:LISTP (CADAR TYPE)) (IL:KWOTE (IL:|for| W IL:|in| (CADAR TYPE) IL:|collect| (IL:LISTGET QUOTE-WRAPPER-LIST W))) (IL:KWOTE (IL:LISTGET QUOTE-WRAPPER-LIST (CADAR TYPE))))) (T (IL:BQUOTE ( IL:LISTGET QUOTE-WRAPPER-LIST (IL:\\\, (CAR TYPE)))))))) (IL:PUTPROPS QUOTE-WRAPPER-NAME IL:MACRO ((TYPE) (IL:LISTGET (IL:CONSTANT (IL:REVERSE QUOTE-WRAPPER-LIST)) TYPE))) (IL:PUTPROPS REPAINT-NEW-LINE IL:MACRO (IL:OPENLAMBDA (LINE) (WHEN (IL:ILESSP (IL:|fetch| NEXT-LINE-Y IL:|of| (CAR LINE)) (IL:|fetch| WINDOW-TOP IL:|of| CONTEXT)) (REPAINT CONTEXT (IL:|fetch| INDENT IL:|of| (CAR LINE)) (IL:|fetch| BASE-LINE-Y IL:|of| (CAR LINE)) (CDR LINE) (IL:|fetch| LINEAR-POINTER IL:|of| CONTEXT)) (WHEN (IL:ILESSP (IL:|fetch| NEXT-LINE-Y IL:|of| (CAR LINE)) (IL:|fetch| WINDOW-BOTTOM IL:|of| CONTEXT)) (IL:|replace| BELOW? IL:|of| CONTEXT IL:|with| T))))) (IL:PUTPROPS RESET-CONTROL-VARIABLES IL:MACRO ((CONTEXT) (WHEN (COMPILING-POST-KOTO) (IL:SETQ *PACKAGE* (IL:FETCH PACKAGE IL:OF CONTEXT)) (IL:SETQ *PRINT-ARRAY* NIL) (IL:SETQ *PRINT-BASE* (IL:FETCH PRINT-BASE IL:OF CONTEXT)) (IL:SETQ *PRINT-CASE* (IL:FETCH PRINT-CASE IL:OF CONTEXT)) (IL:SETQ *PRINT-ESCAPE* T) (IL:SETQ *PRINT-GENSYM* T) (IL:SETQ *PRINT-RADIX* NIL)))) (IL:PUTPROPS SELECT-COMMENT-INDENT IL:MACRO ((KEY LEVEL-1-INDENT LEVEL-2-INDENT LEVEL-3-INDENT) ( IL:SELECTQ KEY (1 LEVEL-1-INDENT) (2 LEVEL-2-INDENT) ((3 4 5) LEVEL-3-INDENT) (IL:SHOULDNT "unexpected comment level")))) (IL:PUTPROPS SET-COMMENT-POSITIONS IL:MACRO ((COMMENT-START-X COMMENT-INDENT FORM-INDENT PAREN-WIDTH NODE CONTEXT) (COND ((IL:IGEQ (IL:IPLUS FORM-INDENT (IL:|fetch| COMMENT-WIDTH IL:|of| CONTEXT)) ( IL:|fetch| RIGHT-MARGIN IL:|of| NODE)) (IL:SETQ COMMENT-START-X (IL:IPLUS (IL:|fetch| START-X IL:|of| NODE) PAREN-WIDTH)) (IL:SETQ COMMENT-INDENT COMMENT-START-X)) (T (IL:SETQ COMMENT-START-X ( IL:IDIFFERENCE (IL:|fetch| RIGHT-MARGIN IL:|of| NODE) (IL:|fetch| COMMENT-WIDTH IL:|of| CONTEXT))) ( IL:SETQ COMMENT-INDENT (IL:IPLUS COMMENT-START-X (IL:|fetch| COMMENT-SEPARATION IL:|of| CONTEXT))))))) (IL:PUTPROPS SET-SELECTION-NOWHERE IL:MACRO ((SELECTION) (IL:|replace| SELECT-NODE IL:|of| SELECTION IL:|with| NIL))) (DEFMACRO CREATE-WEAK-LINK (DEST) (IL:BQUOTE (IL:|create| WEAK-LINK DESTINATION IL:_ (IL:\\\, DEST)))) (IL:PUTPROPS ADVANCE IL:MACRO ((WIDTH) (IL:|add| (IL:|fetch| CURRENT-X IL:|of| CONTEXT) WIDTH))) (IL:PUTPROPS CLOSE-OPEN-NODE IL:MACRO ((CONTEXT) (WHEN (IL:|fetch| OPEN-NODE-CHANGED? IL:|of| CONTEXT) (CLOSE-NODE CONTEXT)))) (IL:PUTPROPS DEAD-NODE? IL:MACRO ((NODE) (EQ 0 (IL:|fetch| DEPTH IL:|of| NODE)))) (IL:PUTPROPS END-UNDO-BLOCK IL:MACRO (NIL (COLLECT-UNDO-BLOCK CONTEXT))) (IL:PUTPROPS ESCAPE-CHAR IL:MACRO ((READ-TABLE) (IL:|fetch| (READTABLEP IL:ESCAPECHAR) IL:|of| (OR READ-TABLE *READTABLE*)))) (IL:PUTPROPS EQ-POINT-TYPE IL:MACRO ((POINT TYPE) (LET ((POINTNODE (IL:|fetch| POINT-NODE IL:|of| POINT))) (IF (IL:|type?| EDIT-SELECTION POINTNODE) (EQ (IL:|fetch| NODE-TYPE IL:|of| (IL:|fetch| SELECT-NODE IL:|of| POINTNODE)) TYPE) (EQ (IL:|fetch| NODE-TYPE IL:|of| POINTNODE) TYPE))))) (IL:PUTPROPS NEXT-LINEAR IL:MACRO ((CONTEXT ITEM) (AND (IL:LISTP (IL:|fetch| LINEAR-POINTER IL:|of| CONTEXT)) (EQ (CAR (IL:|fetch| LINEAR-POINTER IL:|of| CONTEXT)) ITEM)))) (IL:PUTPROPS SET-LINEAR IL:MACRO (IL:OPENLAMBDA (CONTEXT NEW-LPTR) (IL:|replace| LINEAR-POINTER IL:|of| CONTEXT IL:|with| NEW-LPTR) (IF (IL:LISTP (IL:|fetch| LINEAR-PREV IL:|of| CONTEXT)) (RPLACD (IL:|fetch| LINEAR-PREV IL:|of| CONTEXT) NEW-LPTR) (IL:|replace| LINEAR-FORM IL:|of| (IL:|fetch| LINEAR-PREV IL:|of| CONTEXT) IL:|with| NEW-LPTR)))) (IL:PUTPROPS START-UNDO-BLOCK IL:MACRO (NIL (IL:|push| (IL:|fetch| UNDO-LIST IL:|of| CONTEXT) NIL))) (IL:PUTPROPS STEP-LINEAR IL:MACRO ((CONTEXT) (IL:|replace| LINEAR-POINTER IL:|of| CONTEXT IL:|with| ( CDR (IL:|replace| LINEAR-PREV IL:|of| CONTEXT IL:|with| (IL:|fetch| LINEAR-POINTER IL:|of| CONTEXT)))) )) (IL:PUTPROPS SUBNODE IL:MACRO (X (IF (EQ (CAR X) 1) (LIST (QUOTE CADR) (LIST (QUOTE IL:FETCH) (QUOTE SUB-NODES) (CADR X))) (LIST (QUOTE CADR) (LIST (QUOTE IL:NTH) (LIST (QUOTE IL:FETCH) (QUOTE SUB-NODES) (CADR X)) (CAR X)))))) (IL:PUTPROPS UNDO-BY IL:MACRO (INFO (LIST (QUOTE IL:PUSH) (QUOTE (IL:|fetch| UNDO-LIST IL:|of| CONTEXT )) (LIST* (QUOTE LIST) (IL:KWOTE (CAR INFO)) (CDR INFO))))) (IL:PUTPROPS ZAP-CLISP-TRANSLATION IL:MACRO ((X) (AND IL:CLISPARRAY (IL:PUTHASH X NIL IL:CLISPARRAY))) ) (IL:PUTPROPS SMASH-USING IL:MACRO (X (IL:|bind| (SRC IL:_ (IF (IL:ATOM (CADDR X)) (CADDR X) (QUOTE $$SOURCE))) DEST (DESCR IL:_ (IL:GETDESCRIPTORS (CAR X))) IL:|first| (IL:SETQ DEST (LIST (QUOTE IL:REPLACEFIELDVAL) (LIST (QUOTE QUOTE) (CAR DESCR)) (CADR X) (LIST (QUOTE IL:FETCHFIELD) (LIST (QUOTE QUOTE) (CAR DESCR)) SRC))) (IL:SETQ DESCR (CDR DESCR)) IL:|while| DESCR IL:|do| (IL:SETQ DEST (LIST ( QUOTE IL:FREPLACEFIELDVAL) (LIST (QUOTE QUOTE) (CAR DESCR)) DEST (LIST (QUOTE IL:FETCHFIELD) (LIST ( QUOTE QUOTE) (CAR DESCR)) SRC))) (IL:SETQ DESCR (CDR DESCR)) IL:|finally| (WHEN (NOT (IL:ATOM (CADDR X ))) (IL:SETQ DEST (LIST (QUOTE LET) (LIST (LIST (QUOTE $$SOURCE) (CADDR X))) DEST))) (RETURN DEST)))) (IL:PUTPROPS IL:HALF IL:MACRO ((IL:X) (IL:LRSH IL:X 1))) (DEFPARAMETER *IL-CL-CONFLICTS* (QUOTE (IL:*PRINT-STRUCTURE* IL:* IL:APPEND IL:APPLY IL:ASSOC IL:ATOM IL:BLOCK IL:CHARACTER IL:EQUAL IL:ERROR IL:FLOATP IL:FORMAT IL:FUNCTION IL:GETHASH IL:IF IL:LAMBDA IL:LENGTH IL:LISTP IL:MAPCAR IL:NTH IL:NUMBER IL:NUMBERP IL:PRIN1 IL:READ IL:REVERSE IL:SETQ IL:SPACE IL:STRINGP IL:TERPRI))) (DEFPARAMETER *IL-IMPORTS* (QUOTE (IL:\" IL:$$ITERATE IL:$$LST1 IL:$$OUT IL:\( IL:*DISPLAY-EDITOR* IL:\, IL:\. IL:.P2 IL:/DECLAREDATATYPE IL:\; IL:|;;| IL:|;;;| IL:? IL:ACCESSFNS IL:ADD.PROCESS IL:ADD1 IL:ADDSPELL IL:ADDSPELLFLG IL:ADDTOVAR IL:ALIST IL:ALISTS IL:ALLOCSTRING IL:APPLY* IL:ASCENT IL:ATM IL:ATTACHWINDOW IL:AWAIT.EVENT IL:BASE IL:BITBLT IL:BITMAPHEIGHT IL:BITMAPS IL:BITMAPWIDTH IL:BITS IL:BKSYSBUF IL:BLACKSHADE IL:BLTSHADE IL:BOLD IL:BOLDFONT IL:BOTTOM IL:BOX IL:BQUOTE IL:BS IL:BUTTONEVENTFN IL:BUTTONS IL:C IL:CASEINSENSITIVE IL:CCODEP IL:CHANGENAME IL:CHANGEOFFSETFLG IL:CHARCODE IL:CHARDELETE IL:CHARWIDTH IL:CHCON1 IL:CLEARBUF IL:CLEARW IL:CLISP\: IL:CLISPARRAY IL:CLISPFONT IL:CLISPTRAN IL:CLISPWORD IL:CLOCK IL:CLOSEFN IL:CLOSEW IL:COLUMN IL:COLUMNSPACE IL:COMMA IL:COMMENTFLG IL:COMMENTFONT IL:COMS IL:COMTAIL IL:CONCAT IL:CONCATLIST IL:CONSTANT IL:CONSTANTS IL:CONTROL IL:COPY IL:COPYALL IL:COPYRIGHT IL:COPYTERMTABLE IL:CR IL:CREATE IL:CREATE.EVENT IL:CREATE.MONITORLOCK IL:CREATEREGION IL:CREATEW IL:CTRL IL:CTRLV IL:CURSORCREATE IL:DATATYPE IL:DATE IL:DATUM IL:DECLARATIONS\: IL:DECLARE\: IL:DEFAULTFONT IL:DEFINEQ IL:DEL IL:DESCENT IL:DOCOPY IL:DOEVAL@COMPILE IL:DON\'T IL:DONTCOPY IL:DONTEVAL@LOAD IL:DONTWAIT IL:DOWINDOWCOM IL:DREMOVE IL:DREVERSE IL:DSP IL:DSPCLIPPINGREGION IL:DSPFONT IL:DSPLINEFEED IL:DSPRIGHTMARGIN IL:DSPXOFFSET IL:DSPXPOSITION IL:DSPYOFFSET IL:|Definition-for-EDITDATE| IL:|Definition-for-EDITE| IL:|Definition-for-EDITL| IL:E IL:ECHOMODE IL:EDIT IL:EDITCHANGES IL:EDITFERROR IL:EDITGETD IL:EDITMACROS IL:EDITMODE IL:ENVIRONMENT IL:EOL IL:EQMEMB IL:ERSETQ IL:ESC IL:ESCAPE IL:ESCAPECHAR IL:EVAL@COMPILE IL:EVALV IL:EXPANDFN IL:EXPANDREGIONFN IL:EXPANDW IL:EXPR IL:EXTENT IL:FCHARACTER IL:FETCHFIELD IL:FILECREATED IL:FILEMAP IL:FILEPKGFLG IL:FILES IL:FILESLOAD IL:FILETYPE IL:FIND.PROCESS IL:FIXEDITDATE IL:FIXP IL:FIXR IL:FLAG IL:FLAGBITS IL:FLASHWINDOW IL:FLENGTH IL:FM.CHANGELABEL IL:FM.CHANGESTATE IL:FM.DONTRESHAPE IL:FM.EDITITEM IL:FM.GETITEM IL:FM.ITEMPROP IL:FM.RESETMENU IL:FMEMB IL:FN IL:FNS IL:FONT IL:FONTCREATE IL:FONTPROP IL:FORM IL:FORWORD IL:FREEMENU IL:FREPLACEFIELDVAL IL:FULLXPOINTER IL:FUNCTIONS IL:GACHA IL:GETD IL:GETDEF IL:GETDESCRIPTORS IL:GETPROMPTWINDOW IL:GETPROP IL:GETPROPLIST IL:GETREGION IL:GETSYNTAX IL:GLOBALVARS IL:GROUP IL:HALF IL:HEIGHT IL:HEIGHTIFWINDOW IL:HELVETICA IL:ICON IL:ICONWINDOW IL:ID IL:IDIFFERENCE IL:IFWORD IL:IGEQ IL:IGREATERP IL:ILEQ IL:ILESSP IL:IMAX IL:IMIN IL:IMINUS IL:IN/SCROLL/BAR? IL:INNERESCQUOTE IL:INFOHOOK IL:INITRECORDS IL:INITVARS IL:INPUT IL:INSIDEP IL:INTERPRESS IL:INVERT IL:IPLUS IL:IQUOTIENT IL:ITALICFONT IL:ITEM IL:ITEMS IL:ITEMWIDTH IL:ITIMES IL:KEYACTION IL:KEYACTIONTABLE IL:KEYBOARDSTREAM IL:KEYDOWNP IL:KWOTE IL:L IL:L-CASE IL:LABEL IL:LASTMOUSESTATE IL:LASTMOUSEX IL:LASTMOUSEY IL:LCONC IL:LEFT IL:LEFTBRACKET IL:LEFTPAREN IL:LEQ IL:LINEDELETE IL:LINKS IL:LISTGET IL:LISTPUT IL:LITATOM IL:LOCALCLOSE IL:LOCALVARS IL:LRSH IL:MACRO IL:MACROS IL:MAINWINDOW IL:MAKEFILE-ENVIRONMENT IL:MARKASCHANGED IL:MARKASCHANGEDFNS IL:MASK IL:MAXWIDTH IL:MEMB IL:MENU IL:MENUFONT IL:MENUOFFSET IL:MESS IL:MICASPERPT IL:MIDDLE IL:MKSTRING IL:MOUSE IL:MOUSECONFIRM IL:MOUSESTATE IL:MOVE IL:MOVETO IL:MULTESCAPECHAR IL:MULTIPLE-ESCAPE IL:NAME IL:NCHARS IL:NCONC1 IL:NEQ IL:NILL IL:NLAMBDA IL:NLISTP IL:NLSETQ IL:NOBIND IL:NONE IL:NOTIFY.EVENT IL:NTHCHARCODE IL:OBTAIN.MONITORLOCK IL:OFFST IL:OPENLAMBDA IL:OPENSTRINGSTREAM IL:OPENWP IL:P IL:PACKAGEDELIM IL:PAINT IL:POINTER IL:PRETTYCOMPRINT IL:PRIN2 IL:PROCESS IL:PROCESS.APPLY IL:PROCESS.EVAL IL:PROCESS.EVALV IL:PROCESSP IL:PROCESSPROP IL:PROCTYPEAHEAD IL:PROMPTFORWORD IL:PROMPTWINDOW IL:PROP IL:PROPLST IL:PROPS IL:PUTD IL:PUTDEF IL:PUTHASH IL:PUTPROP IL:PUTPROPS IL:QUOTIENT IL:READCODE IL:READP IL:READSA IL:RECORD IL:RECORDS IL:RECORDTRAN IL:REDISPLAYW IL:REGION IL:REJECTMAINCOMS IL:RELEASE.MONITORLOCK IL:RELMOVETO IL:REPAINTFN IL:REPLACEFIELDVAL IL:REPOSITIONATTACHEDWINDOWS IL:RESETLST IL:RESETSAVE IL:RESETVAR IL:RESHAPEFN IL:RESTARTABLE IL:RETFROM IL:RETYPE IL:RIGHT IL:RIGHTBRACKET IL:RIGHTBUTTONFN IL:RIGHTPAREN IL:ROWSPACE IL:RPAQ IL:RPAQ? IL:RPAQQ IL:RPLCHARCODE IL:RPLNODE2 IL:RPLSTRING IL:SCROLL.HANDLER IL:SCROLLBYREPAINTFN IL:SCROLLEXTENTUSE IL:SCROLLFN IL:SCROLLW IL:SELCHARQ IL:SELECTEDFN IL:SELECTQ IL:SEPRCHAR IL:SETFS IL:SETINTERRUPT IL:SETPROPLIST IL:SETSYNTAX IL:SETTERMTABLE IL:SHAPEW IL:SHIFT IL:SHIFTDOWNP IL:SHOULDNT IL:SHRINKFN IL:SMALLP IL:SMARTARGLIST IL:SP IL:SPECVARS IL:SPELLFILE IL:STATE IL:STKPOS IL:STREQUAL IL:STRINGDELIM IL:STRINGWIDTH IL:STRPOS IL:SUB1 IL:SUBSTRING IL:SYSRECORDS IL:SYSTEMRECLST IL:TAB IL:TABLE IL:TAIL IL:TCONC IL:TEDIT.INSERT IL:TEDIT.PARALOOKS IL:THIS.PROCESS IL:TIMES IL:TITLE IL:TITLEDICON IL:TITLEDICONW IL:TITLEREG IL:TOP IL:TOTOPW IL:TTY.PROCESS IL:TTY.PROCESSP IL:TTY/EDITDATE IL:TTY/EDITE IL:TTY/EDITL IL:TTY\: IL:TTYDISPLAYSTREAM IL:TTYEXITFN IL:TYPENAME IL:U-CASE IL:UNTILMOUSESTATE IL:UP IL:USEDFREE IL:VARIABLES IL:VARS IL:VARTYPE IL:WAIT.FOR.TTY IL:WHITESHADE IL:WIDTH IL:WINDOW IL:WINDOWADDPROP IL:WINDOWENTRYFN IL:WINDOWPROP IL:WINDOWREGION IL:WITH.MONITOR IL:WORD IL:WORDDELETE IL:WXOFFSET IL:WYOFFSET IL:X IL:Y IL:[ IL:\\\, IL:\\\,. IL:\\\,@ IL:\\ADDBASE IL:\\BACKGROUND IL:\\BLT IL:\\BLTCHAR IL:\\CARET.CREATE IL:\\CARET.DOWN IL:\\CARET.FLASH? IL:\\DEFAULTKEYACTION IL:\\DTEST IL:\\GETBASE IL:\\GETSYSBUF IL:\\KEYBOARD.STREAM IL:\\LINEBUF.OFD IL:\\PUTBASE IL:\\SAVEVMBACKGROUND IL:\\SYNCODE IL:] IL:^ IL:_ IL:ADD IL:ALWAYS IL:AS IL:BIND IL:BY IL:CHANGE IL:|changes| IL:COLLECT IL:COUNT IL:CREATE IL:|date:| IL:DO IL:EACHTIME IL:ELSE IL:ELSEIF IL:FETCH IL:FFETCH IL:FINALLY IL:FIRST IL:FOR IL:FREPLACE IL:FROM WHEN IL:IN IL:INSTRING IL:JOIN IL:LARGEST IL:NEVER IL:OF IL:OLD IL:ON IL:OUTOF IL:POP IL:|previous| IL:|printout| IL:PUSH IL:PUSHNEW IL:REPEATUNTIL IL:REPEATWHILE IL:REPLACE IL:SMALLEST IL:SUM IL:THEN IL:THEREIS IL:TO IL:|to:| IL:TYPE? IL:UNLESS IL:UNTIL IL:USING IL:WHEN IL:WHERE IL:WHILE IL:WITH IL:{ IL:}))) (IL:|printout| T T "EXPORTS.ALL must be loaded to compile SEdit" T) (IL:|printout| T T "SEDIT-ACCESS must be REMADE NEW if you change a record" T) (IL:PUTPROPS IL:SEDIT-DECLS IL:COPYRIGHT ("Xerox Corporation" 1987 1988)) NIL \ No newline at end of file diff --git a/lispusers/MIGRATION/TABLEBROWSERDECLS b/lispusers/MIGRATION/TABLEBROWSERDECLS new file mode 100644 index 00000000..a8a265a1 --- /dev/null +++ b/lispusers/MIGRATION/TABLEBROWSERDECLS @@ -0,0 +1,35 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") +(FILECREATED "27-Jan-88 17:04:01" {ERIS}LIBRARY>TABLEBROWSERDECLS.;5 5052 + + changes to%: (RECORDS TABLEBROWSER) + + previous date%: "18-Oct-85 18:10:50" {ERIS}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 diff --git a/lispusers/MIGRATION/TABLEBROWSERDECLS.LCOM b/lispusers/MIGRATION/TABLEBROWSERDECLS.LCOM new file mode 100644 index 00000000..281ef3ae --- /dev/null +++ b/lispusers/MIGRATION/TABLEBROWSERDECLS.LCOM @@ -0,0 +1 @@ +(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "19-Jan-93 19:57:47" ("compiled on " {DSK}local>src>tape>MIGRATION>TABLEBROWSERDECLS.;1) "11-Jul-91 21:52:09" bcompl'd in "Lispcore 11-Jul-91 ..." dated "11-Jul-91 21:57:45") (FILECREATED "27-Jan-88 17:04:01" {ERIS}LIBRARY>TABLEBROWSERDECLS.;5 5052 changes to%: ( RECORDS TABLEBROWSER) previous date%: "18-Oct-85 18:10:50" {ERIS}LIBRARY>TABLEBROWSERDECLS.;2) (PRETTYCOMPRINT TABLEBROWSERDECLSCOMS) (RPAQQ TABLEBROWSERDECLSCOMS ((RECORDS TABLEBROWSER TABLEITEM) (CONSTANTS TB.LEFT.MARGIN))) (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)) (RPAQQ TB.LEFT.MARGIN 8) (CONSTANTS TB.LEFT.MARGIN) (PUTPROPS TABLEBROWSERDECLS COPYRIGHT ("Xerox Corporation" 1985 1988)) NIL \ No newline at end of file diff --git a/lispusers/MIGRATION/TRANSLATOR-ASSISTANT b/lispusers/MIGRATION/TRANSLATOR-ASSISTANT new file mode 100644 index 00000000..160b4f1f --- /dev/null +++ b/lispusers/MIGRATION/TRANSLATOR-ASSISTANT @@ -0,0 +1,1646 @@ +(DEFINE-FILE-INFO PACKAGE "IL-CONVERT" READTABLE "XCL") +(IL:FILECREATED "26-Jan-90 10:14:54" IL:|{DSK}/users/welch/migration/TRANSLATOR-ASSISTANT.;5| 89355 + + IL:|changes| IL:|to:| (IL:VARIABLES *DEFAULT-OPTIONS-FREEMENU-DESCRIPTION* + *OPTIONS-FREEMENU-DESCRIPTION*) + + IL:|previous| IL:|date:| "25-Jan-90 14:46:05" +IL:|{DSK}/users/welch/migration/TRANSLATOR-ASSISTANT.;4|) + + +; Copyright (c) 1989, 1990 by ENVOS Corporation. All rights reserved. + +(IL:PRETTYCOMPRINT IL:TRANSLATOR-ASSISTANTCOMS) + +(IL:RPAQQ IL:TRANSLATOR-ASSISTANTCOMS + ((IL:DECLARE\: IL:EVAL@LOAD IL:EVAL@COMPILE IL:DONTCOPY + + (IL:* IL:|;;| "Sure wish FILESLOAD did what I want...") + + (IL:P (MAPC #'(LAMBDA (X) + (IL:LOAD X 'IL:PROP)) + '(IL:SEDIT-DECLS IL:FILEPKGRECORDS IL:TABLEBROWSERDECLS)))) + (IL:VARIABLES *DEF-EDITOR-ADDED-SEDIT-COMMANDS* *DEF-EDITOR-SEDIT-COMTAB-SPEC* + *DEF-EDITOR-SEDIT-COMTAB* *DEF-EDITOR-SEDIT-ENVIRONMENT* + *DEFAULT-OPTIONS-FREEMENU-DESCRIPTION* *ITERATION-OPERS* + *OPTIONS-FREEMENU-DESCRIPTION* *TRANSLATOR-CONTROL-FREEMENU-DESCRIPTION* + *TRANSLATOR-OPTIONS* *USER-ADDED-TEMPLATES* *USER-ADDED-TRANSLATOR-MACROS* + *WARN-FOR-COMPLEX-I.S.-FORMS* *FILE-CONTEXT-FREEMENU-DESCRIPTION* *FILE-CONTEXTS*) + (IL:STRUCTURES FILE-CONTEXT WARNING-ENTRY WARNING-HEADER) + (IL:FUNCTIONS ADD\'L-FILE-SELECTEDFN COMPARE-PARAMETER-LISTS CONVERT-FILE-FOR-CONTEXT + CONVERT-ONE-FILECOM-FOR-CONTEXT CONVERT-SETFS-FILECOM CONVERT-UNKNOWN-COM + DEF-EDITOR-BROWSE-WARNINGS DEF-EDITOR-CONVERT-STRUCTURE + DEF-WARNING-BROWSER-DELETEDFN DEF-WARNING-BROWSER-SELECTEDFN + ENTER-NEW-MACRO-TEMPLATE FILE-WARNING-BROWSER-DELETEDFN + FILE-WARNING-BROWSER-SELECTEDFN FS-WINDOW-ADD\'L-FILE-BROWSER + FS-WINDOW-BROWSE-TRANSLATIONS FS-WINDOW-BROWSE-WARNINGS FS-WINDOW-DO-TRANSLATE + FS-WINDOW-EDIT-OPTIONS FS-WINDOW-ICONFN FS-WINDOW-SAVE-CONTEXT + FS-WINDOW-SELECT-NEXT-DEFINITION FS-WINDOW-WRITE-TRANSLATION + FS-WINDOW-WRITE-TRANSLATION-INTERNAL GET-FILE-CONTEXT-OPTION INVERT-CALLER-LIST + LOCATE-SUBEXPRESSION MAKE-WARNINGS-BROWSER MAP-INTO-CONTEXT MAPCAN-INTO-CONTEXT + MENU-CHOOSE NEW-FILE-CONTEXT NTH-SUBEXPRESSION OPTIONS-EDITOR-ACCEPT + OPTIONS-EDITOR-BROWSE-TEMPLATES OPTIONS-EDITOR-BROWSE-TRANSLATOR-MACROS + OPTIONS-EDITOR-CLOSEW OPTIONS-EDITOR-NEW-TEMPLATE + OPTIONS-EDITOR-NEW-TRANSLATOR-MACRO OPTIONS-EDITOR-REVERT PACKAGE-VALIDATIONFN + PARSE-FILENAME-FOR-FILE-CONTEXT PROMPT-FOR-FILENAME RECORD-WARNING + TEMPLATE-BROWSER-CLOSEFN TEMPLATE-BROWSER-SELECTEDFN TRANSLATION-BROWSER-SELECTEDFN + TRANSLATOR-EDIT-DEFAULT-OPTIONS TRANSLATOR-NEW-FILE-CONTEXT + TRANSLATOR-NEW-FILE-CONTEXT-INTERNAL TRANSLATOR-NOTE-ADDITIONAL-FILE + TRANSLATOR-READ-SAVED-CONTEXT TRANSMACRO-BROWSER-CLOSEFN + TRANSMACRO-BROWSER-SELECTEDFN UNKNOWN-MACRO-FORM WALKER-FIND-PARAMETER-LIST + WARN-FOR-PARM-CHANGES WARNING-DEFINITIONS-BROWSER-SELECTEDFN WB.BUTTONEVENTFN + WB.CLOSEFN WB.DO.ITEM.SELECTION WITH-FILE-CONTEXT-OPTIONS YESNOCHANGESTATE) + (IL:VARIABLES *TRANSLATOR-MAIN-MENU*) + (IL:P (IL:TOTOPW *TRANSLATOR-MAIN-MENU*)))) +(IL:DECLARE\: IL:EVAL@LOAD IL:EVAL@COMPILE IL:DONTCOPY + +(MAPC #'(LAMBDA (X) + (IL:LOAD X 'IL:PROP)) + '(IL:SEDIT-DECLS IL:FILEPKGRECORDS IL:TABLEBROWSERDECLS)) +) + +(DEFPARAMETER *DEF-EDITOR-ADDED-SEDIT-COMMANDS* '((DEF-EDITOR-CONVERT-STRUCTURE NIL T "1,="))) + +(DEFPARAMETER *DEF-EDITOR-SEDIT-COMTAB-SPEC* (APPEND *DEF-EDITOR-ADDED-SEDIT-COMMANDS* + SEDIT::COMMAND-TABLE-SPEC)) + +(DEFPARAMETER *DEF-EDITOR-SEDIT-COMTAB* (SEDIT::CREATE-COMMAND-TABLE + *DEF-EDITOR-SEDIT-COMTAB-SPEC*)) + +(DEFPARAMETER *DEF-EDITOR-SEDIT-ENVIRONMENT* (IL:CREATE SEDIT::EDIT-ENV IL:USING + + SEDIT::LISP-EDIT-ENVIRONMENT + SEDIT::COMMAND-TABLE + IL:_ (FIRST + *DEF-EDITOR-SEDIT-COMTAB* + ) + SEDIT::HELP-MENU IL:_ + (SECOND + *DEF-EDITOR-SEDIT-COMTAB* + ))) + +(DEFPARAMETER *DEFAULT-OPTIONS-FREEMENU-DESCRIPTION* + '((IL:PROPS IL:FONT (IL:TIMESROMAN 10)) + ((TYPE IL:DISPLAY IL:LABEL "Warn for complex I.S. forms") + (TYPE IL:STATE IL:CHANGESTATE YESNOCHANGESTATE IL:LABEL "No" IL:ID + *WARN-FOR-COMPLEX-I.S.-FORMS* IL:FONT (IL:GACHA 10 IL:BOLD))) + ((TYPE IL:DISPLAY IL:LABEL "Unknown macros: ") + (TYPE IL:NWAY IL:COLLECTION *UNKNOWN-MACRO-ACTION* IL:ID :UM-SILENT IL:LABEL "ignore" + IL:NWAYPROPS (IL:INITSTATE (IL:GROUP :UM-WARN))) + (TYPE IL:NWAY IL:COLLECTION *UNKNOWN-MACRO-ACTION* IL:ID :UM-WARN IL:LABEL "warn") + (TYPE IL:NWAY IL:COLLECTION *UNKNOWN-MACRO-ACTION* IL:ID :UM-PROMPT IL:LABEL "prompt")) + ((TYPE IL:EDITSTART IL:LINKS (IL:EDIT (IL:GROUP *PACKAGE-FOR-IL-SYMBOLS*)) + IL:LABEL "Package for IL symbols:") + (TYPE IL:EDIT IL:LABEL "" IL:ID *PACKAGE-FOR-IL-SYMBOLS* IL:FONT (IL:GACHA 10 IL:BOLD) + IL:MAXWIDTH 100)) + ((TYPE IL:EDITSTART IL:LINKS (IL:EDIT (IL:GROUP *PACKAGE-FOR-RESULT-FILE*)) + IL:LABEL "Package of result file:") + (TYPE IL:EDIT IL:LABEL "" IL:ID *PACKAGE-FOR-RESULT-FILE* IL:FONT (IL:GACHA 10 IL:BOLD) + IL:MAXWIDTH 100 VALIDATION-FN PACKAGE-VALIDATIONFN IL:LIMITCHARS OPTIONS-LIMITCHARFN)) + ((TYPE IL:DISPLAY IL:LABEL "All parameters optional") + (TYPE IL:STATE IL:CHANGESTATE YESNOCHANGESTATE IL:LABEL "No" IL:ID *PARAMETERS-ALWAYS-OPTIONAL* + IL:FONT (IL:GACHA 10 IL:BOLD))) + ((TYPE IL:DISPLAY IL:LABEL "Extra arguments ignored") + (TYPE IL:STATE IL:CHANGESTATE YESNOCHANGESTATE IL:LABEL "No" IL:ID *ADD-REST-ARG* IL:FONT + (IL:GACHA 10 IL:BOLD))) + ((TYPE IL:DISPLAY IL:LABEL "Warn for all IL symbols") + (TYPE IL:STATE IL:CHANGESTATE YESNOCHANGESTATE IL:LABEL "No" IL:ID *WARN-FOR-ALL-IL-SYMBOLS* + IL:FONT (IL:GACHA 10 IL:BOLD))) + ((TYPE IL:EDITSTART IL:LINKS (IL:EDIT (IL:GROUP *WARN-FOR-IL-SYMBOLS-LOWER-THAN-THIS*)) + IL:LABEL "Warn for IL symbols below: ") + (TYPE IL:EDIT IL:LABEL "NIL" IL:ID *WARN-FOR-IL-SYMBOLS-LOWER-THAN-THIS* IL:FONT + (IL:GACHA 10 IL:BOLD) + IL:MAXWIDTH 100)) + ((TYPE IL:DISPLAY IL:LABEL "GetValue forms: ")) + ((IL:PROPS IL:LEFT 10) + (TYPE IL:NWAY IL:COLLECTION *GETVALUE-TRANSLATION* IL:ID :SLOT-VALUE IL:LABEL "slot-value" + IL:NWAYPROPS (IL:INITSTATE (IL:GROUP :SLOT-VALUE))) + (TYPE IL:NWAY IL:COLLECTION *GETVALUE-TRANSLATION* IL:ID :ACCESSOR IL:LABEL "accessor") + (TYPE IL:NWAY IL:COLLECTION *GETVALUE-TRANSLATION* IL:ID :ACTIVE-VALUE IL:LABEL + "active value system")) + ((TYPE IL:DISPLAY IL:LABEL "Slot for IV Props in every class") + (TYPE IL:STATE IL:CHANGESTATE YESNOCHANGESTATE IL:LABEL "No" IL:ID *ALWAYS-INCLUDE-PROPS* + IL:FONT (IL:GACHA 10 IL:BOLD))) + ((TYPE IL:DISPLAY IL:LABEL "CL Macro Templates:") + (IL:LABEL "Browse" IL:SELECTEDFN OPTIONS-EDITOR-BROWSE-TEMPLATES IL:BOX 1 IL:FONT (IL:GACHA + 10)) + (IL:LABEL "New" IL:SELECTEDFN OPTIONS-EDITOR-NEW-TEMPLATE IL:BOX 1 IL:FONT (IL:GACHA 10))) + ((TYPE IL:DISPLAY IL:LABEL "IL Translator Macros:") + (IL:LABEL "Browse" IL:SELECTEDFN OPTIONS-EDITOR-BROWSE-TRANSLATOR-MACROS IL:BOX 1 IL:FONT + (IL:GACHA 10)) + (IL:LABEL "New" IL:SELECTEDFN OPTIONS-EDITOR-NEW-TRANSLATOR-MACRO IL:BOX 1 IL:FONT (IL:GACHA + 10))) + ((IL:LABEL "Accept" IL:SELECTEDFN OPTIONS-EDITOR-ACCEPT IL:BOX 1 IL:FONT (IL:GACHA 10)) + (IL:LABEL "Abort" IL:SELECTEDFN OPTIONS-EDITOR-CLOSEW IL:BOX 1 IL:FONT (IL:GACHA 10) + IL:HJUSTIFY IL:CENTER) + (IL:LABEL "Revert" IL:SELECTEDFN OPTIONS-EDITOR-REVERT IL:BOX 1 IL:FONT (IL:GACHA 10) + IL:HJUSTIFY IL:RIGHT)))) + +(DEFPARAMETER *ITERATION-OPERS* NIL) + +(DEFPARAMETER *OPTIONS-FREEMENU-DESCRIPTION* + '((IL:PROPS IL:FONT (IL:TIMESROMAN 10)) + ((TYPE IL:DISPLAY IL:LABEL "Warn for complex I.S. forms") + (TYPE IL:STATE IL:CHANGESTATE YESNOCHANGESTATE IL:LABEL "No" IL:ID + *WARN-FOR-COMPLEX-I.S.-FORMS* IL:FONT (IL:GACHA 10 IL:BOLD))) + ((TYPE IL:DISPLAY IL:LABEL "Unknown macros: ") + (TYPE IL:NWAY IL:COLLECTION *UNKNOWN-MACRO-ACTION* IL:ID :UM-SILENT IL:LABEL "ignore" + IL:NWAYPROPS (IL:INITSTATE (IL:GROUP :UM-WARN))) + (TYPE IL:NWAY IL:COLLECTION *UNKNOWN-MACRO-ACTION* IL:ID :UM-WARN IL:LABEL "warn") + (TYPE IL:NWAY IL:COLLECTION *UNKNOWN-MACRO-ACTION* IL:ID :UM-PROMPT IL:LABEL "prompt")) + ((TYPE IL:EDITSTART IL:LINKS (IL:EDIT (IL:GROUP *PACKAGE-FOR-IL-SYMBOLS*)) + IL:LABEL "Package for IL symbols:") + (TYPE IL:EDIT IL:LABEL "" IL:ID *PACKAGE-FOR-IL-SYMBOLS* IL:FONT (IL:GACHA 10 IL:BOLD) + IL:MAXWIDTH 100 VALIDATION-FN PACKAGE-VALIDATIONFN)) + ((TYPE IL:EDITSTART IL:LINKS (IL:EDIT (IL:GROUP *PACKAGE-FOR-RESULT-FILE*)) + IL:LABEL "Package of result file:") + (TYPE IL:EDIT IL:LABEL "" IL:ID *PACKAGE-FOR-RESULT-FILE* IL:FONT (IL:GACHA 10 IL:BOLD) + IL:MAXWIDTH 100 VALIDATION-FN PACKAGE-VALIDATIONFN)) + ((TYPE IL:DISPLAY IL:LABEL "All parameters optional") + (TYPE IL:STATE IL:CHANGESTATE YESNOCHANGESTATE IL:LABEL "No" IL:ID *PARAMETERS-ALWAYS-OPTIONAL* + IL:FONT (IL:GACHA 10 IL:BOLD))) + ((TYPE IL:DISPLAY IL:LABEL "Extra arguments ignored") + (TYPE IL:STATE IL:CHANGESTATE YESNOCHANGESTATE IL:LABEL "No" IL:ID *ADD-REST-ARG* IL:FONT + (IL:GACHA 10 IL:BOLD))) + ((TYPE IL:DISPLAY IL:LABEL "Warn for all IL symbols") + (TYPE IL:STATE IL:CHANGESTATE YESNOCHANGESTATE IL:LABEL "No" IL:ID *WARN-FOR-ALL-IL-SYMBOLS* + IL:FONT (IL:GACHA 10 IL:BOLD))) + ((TYPE IL:DISPLAY IL:LABEL "GetValue forms: ") + (TYPE IL:NWAY IL:COLLECTION *GETVALUE-TRANSLATION* IL:ID :SLOT-VALUE IL:LABEL "slot-value" + IL:NWAYPROPS (IL:INITSTATE (IL:GROUP :SLOT-VALUE))) + (TYPE IL:NWAY IL:COLLECTION *GETVALUE-TRANSLATION* IL:ID :ACCESSOR IL:LABEL "accessor") + (TYPE IL:NWAY IL:COLLECTION *GETVALUE-TRANSLATION* IL:ID :ACTIVE-VALUE IL:LABEL + "active value system")) + ((TYPE IL:DISPLAY IL:LABEL "Slot for IV Props in every class") + (TYPE IL:STATE IL:CHANGESTATE YESNOCHANGESTATE IL:LABEL "No" IL:ID *ALWAYS-INCLUDE-PROPS* + IL:FONT (IL:GACHA 10 IL:BOLD))) + ((TYPE IL:EDITSTART IL:LINKS (IL:EDIT (IL:GROUP *WARN-FOR-IL-SYMBOLS-LOWER-THAN-THIS*)) + IL:LABEL "Warn for IL symbols below: ") + (TYPE IL:EDIT IL:LABEL "NIL" IL:ID *WARN-FOR-IL-SYMBOLS-LOWER-THAN-THIS* IL:FONT + (IL:GACHA 10 IL:BOLD) + IL:MAXWIDTH 100)) + ((IL:LABEL "Accept" IL:BOX 1 IL:FONT (IL:GACHA 10) + IL:SELECTEDFN OPTIONS-EDITOR-ACCEPT) + (IL:LABEL "Abort" IL:SELECTEDFN OPTIONS-EDITOR-CLOSEW IL:BOX 1 IL:FONT (IL:GACHA 10) + IL:HJUSTIFY IL:CENTER) + (IL:LABEL "Revert" IL:HJUSTIFY IL:RIGHT IL:BOX 1 IL:FONT (IL:GACHA 10) + IL:SELECTEDFN OPTIONS-EDITOR-REVERT)))) + +(DEFPARAMETER *TRANSLATOR-CONTROL-FREEMENU-DESCRIPTION* + '(((IL:LABEL "Code Migration Tool" IL:FONT (IL:MODERN 18 IL:BOLD) + IL:HJUSTIFY IL:CENTER TYPE IL:DISPLAY)) + ((IL:PROPS IL:FONT (IL:MODERN 12)) + (IL:LABEL "New File" IL:BOX 2 IL:SELECTEDFN TRANSLATOR-NEW-FILE-CONTEXT IL:MESSAGE + "Open a new File Window, prompting for file name.") + (IL:LABEL "Get State" IL:BOX 2 IL:SELECTEDFN TRANSLATOR-READ-SAVED-CONTEXT IL:MESSAGE + "Restore a saved File Context to a window") + (IL:LABEL "Edit Default Options" IL:BOX 2 IL:SELECTEDFN TRANSLATOR-EDIT-DEFAULT-OPTIONS + IL:MESSAGE "Open an editor for the default translation options")))) + +(DEFPARAMETER *TRANSLATOR-OPTIONS* '(*WARN-FOR-COMPLEX-I.S.-FORMS* *UNKNOWN-MACRO-ACTION* + *PACKAGE-FOR-IL-SYMBOLS* *PACKAGE-FOR-RESULT-FILE* + *PARAMETERS-ALWAYS-OPTIONAL* *ADD-REST-ARG* + *WARN-FOR-ALL-IL-SYMBOLS* + *WARN-FOR-IL-SYMBOLS-LOWER-THAN-THIS* + *GETVALUE-TRANSLATION*) + + "A list of the names of special variables that are translator options.") + +(DEFVAR *USER-ADDED-TEMPLATES* NIL) + +(DEFVAR *USER-ADDED-TRANSLATOR-MACROS* NIL) + +(DEFVAR *WARN-FOR-COMPLEX-I.S.-FORMS* NIL) + +(DEFPARAMETER *FILE-CONTEXT-FREEMENU-DESCRIPTION* + '(((IL:LABEL "File:" TYPE IL:DISPLAY IL:FONT (IL:MODERN 12)) + (IL:ID FILENAME TYPE IL:DISPLAY IL:LABEL "") + (IL:LABEL "Put State" IL:BOX 2 IL:FONT (IL:MODERN 12) + IL:HJUSTIFY IL:RIGHT IL:SELECTEDFN FS-WINDOW-SAVE-CONTEXT)) + ((IL:LABEL "Directory:" TYPE IL:DISPLAY IL:FONT (IL:MODERN 12)) + (IL:ID DIRNAME TYPE IL:DISPLAY IL:LABEL "")) + ((IL:PROPS IL:FONT (IL:MODERN 12)) + (IL:LABEL "Translate" IL:BOX 2 IL:SELECTEDFN FS-WINDOW-DO-TRANSLATE IL:MESSAGE + "Translate from source code, discarding any current warnings.") + (IL:LABEL "Options" IL:BOX 2 IL:SELECTEDFN FS-WINDOW-EDIT-OPTIONS IL:MESSAGE + "Edit translation options for this file") + (IL:LABEL "Write Translation" IL:BOX 2 IL:SELECTEDFN FS-WINDOW-WRITE-TRANSLATION IL:MESSAGE + "Write the translated file to disk") + (IL:LABEL "Next Definition" IL:BOX 2 IL:SELECTEDFN FS-WINDOW-SELECT-NEXT-DEFINITION IL:MESSAGE + "Edit the next definition in the warnings browser")))) + +(DEFVAR *FILE-CONTEXTS* NIL) + +(DEFSTRUCT (FILE-CONTEXT (:PRINT-FUNCTION (LAMBDA (SELF STREAM DEPTH) + (DECLARE (IGNORE DEPTH)) + (FORMAT STREAM "#<~a for ~a @ ~o,~o>" + (TYPE-OF SELF) + (FILE-CONTEXT-FILENAME SELF) + (IL:\\HILOC SELF) + (IL:\\LOLOC SELF))))) + (FILENAME) + (DIRNAME) + (DEFINITIONS) + (DEFINITIONS-LAST-CONS) + (WARNINGS) + (FUNCTION-CALLS) + (FREE-REFERENCES) + (OPTIONS) + (MENU) + (EXPORTED-SYMS)) + +(DEFSTRUCT (WARNING-ENTRY (:CONC-NAME "WE-") + (:TYPE LIST)) + STRING + EXPRESSION + DELETED) + +(DEFSTRUCT (WARNING-HEADER (:CONC-NAME "WH-") + (:TYPE LIST)) + DEFNAME + DEFTYPE + DEFBODY + DELETED) + +(DEFUN ADD\'L-FILE-SELECTEDFN (BROWSER ITEM WINDOW) + (LET* ((TIDATA (IL:|fetch| IL:TIDATA IL:|of| ITEM)) + (NAME (FIRST TIDATA)) + (DIR-AND-HOST (SECOND TIDATA))) + (LET ((CXT (FIND NAME *FILE-CONTEXTS* :TEST 'STRING-EQUAL :KEY 'FILE-CONTEXT-FILENAME))) + (IF CXT + + (IL:* IL:|;;| "This isn't supposed to happen, actually, but just in case...") + + (IL:TOTOPW (FILE-CONTEXT-MENU CXT)) + (TRANSLATOR-NEW-FILE-CONTEXT-INTERNAL NAME DIR-AND-HOST)) + (IL:TB.REMOVE.ITEM BROWSER ITEM) + (WHEN (ZEROP (IL:TB.NUMBER.OF.ITEMS BROWSER)) + (IL:CLOSEW WINDOW))))) + +(DEFUN COMPARE-PARAMETER-LISTS (OLD NEW FN-NAME CONTEXT) + + (IL:* IL:|;;| "See if the lists are compatible...") + + (IL:* IL:|;;| "Maybe someday we'll do fancy analysis. For now, just use EQUAL.") + + (UNLESS (EQUAL OLD NEW) + (CASE (MENU-CHOOSE '(("No action" NIL) + ("Warn in all callers" :WARN) + ("Continue Editing" :ABORT)) + "Parameter list changed") + (:ABORT + + (IL:* IL:|;;| + "Flush out of the SEDIT finish-close sequence, back to editor top level.") + + (XCL:ABORT)) + (:WARN (WARN-FOR-PARM-CHANGES FN-NAME CONTEXT))))) + +(DEFUN CONVERT-FILE-FOR-CONTEXT (FILE-CONTEXT) + (LET* ((*FILE-CONTEXT* FILE-CONTEXT) + (COMS-VAR (CAAR (GET (FILE-CONTEXT-FILENAME FILE-CONTEXT) + 'IL:FILE))) + (FILECOMS (SYMBOL-VALUE COMS-VAR))) + (IF (NULL (FILE-CONTEXT-WARNINGS FILE-CONTEXT)) + (SETF (FILE-CONTEXT-WARNINGS FILE-CONTEXT) + (MAKE-HASH-TABLE :TEST #'EQUAL :SIZE 100)) + (CLRHASH (FILE-CONTEXT-WARNINGS FILE-CONTEXT))) + (SETF (FILE-CONTEXT-DEFINITIONS FILE-CONTEXT) + NIL + (FILE-CONTEXT-DEFINITIONS-LAST-CONS FILE-CONTEXT) + NIL + (FILE-CONTEXT-FREE-REFERENCES FILE-CONTEXT) + NIL + (FILE-CONTEXT-FUNCTION-CALLS FILE-CONTEXT) + NIL + (FILE-CONTEXT-EXPORTED-SYMS FILE-CONTEXT) + NIL) + (WITH-FILE-CONTEXT-OPTIONS FILE-CONTEXT (LET ((REORDERED-FILECOMS (REORDER-FILECOMS FILECOMS + )) + (*PACKAGE* (FIND-PACKAGE + *PACKAGE-FOR-RESULT-FILE*))) + + (IL:* IL:|;;| + "This puts the definitions into the context as a side-effect.") + + (MAPC #'CONVERT-ONE-FILECOM REORDERED-FILECOMS) + )))) + +(DEFUN CONVERT-ONE-FILECOM-FOR-CONTEXT (FILECOM &OPTIONAL (CONTEXT *FILE-CONTEXT*)) + (LET ( + (IL:* IL:|;;| + "We bind these in case the filecom type is unknown... They'll be rebound lower down.") + + (*CURRENT-EXPRESSION* FILECOM) + (*CURRENT-DEFINITION* (CAR FILECOM)) + (*CURRENT-DEFINITION-TYPE* "Filecom")) + (IF (OR (NULL (GET (CAR FILECOM) + 'CONVERT-COM)) + (GET (CAR FILECOM) + 'IGNORES-MAPPING-FN)) + + (IL:* IL:|;;| "If it accepts a mapping function, give it ours which does that stuff.") + + (CONVERT-ONE-FILECOM FILECOM 'MAP-INTO-CONTEXT)))) + +(DEFUN CONVERT-SETFS-FILECOM (COM) + + (IL:* IL:|;;| "These all read out as DEFSETF forms.") + + (MAP-INTO-CONTEXT #'(LAMBDA (NAME) + (IL:GETDEF NAME :SETFS)) + COM)) + +(DEFUN CONVERT-UNKNOWN-COM (COM) + (MAP-INTO-CONTEXT #'(LAMBDA (C) + (WARN "Unable to translate a ~a filecom." (CAR C)) + C) + (LIST COM))) + +(DEFUN DEF-EDITOR-BROWSE-WARNINGS (WINDOW WARNINGS &OPTIONAL FILE-CONTEXT) + (WHEN WARNINGS + (LET ((WB (MAKE-WARNINGS-BROWSER (MAPCAR #'(LAMBDA (W) + (IL:CREATE IL:TABLEITEM + IL:TIDATA IL:_ W + IL:TIDELETED IL:_ (THIRD W))) + WARNINGS) + "Warnings for definition" WINDOW 'IL:TOP + #'(LAMBDA (TB ITEM WINDOW) + (DECLARE (IGNORE TB)) + (PRINC (FIRST (IL:|fetch| IL:TIDATA IL:|of| ITEM)) + WINDOW)) + :SELECTEDFN + 'DEF-WARNING-BROWSER-SELECTEDFN :DELETEDFN 'DEF-WARNING-BROWSER-DELETEDFN + :MAINWINDOWPROP 'WARNINGS-BROWSER))) + (IL:WINDOWPROP WB 'FILE-CONTEXT FILE-CONTEXT) + (IL:WINDOWADDPROP WB 'IL:CLOSEFN #'(LAMBDA (W) + (IL:WINDOWPROP W 'FILE-CONTEXT NIL))) + WB))) + +(DEFUN DEF-EDITOR-CONVERT-STRUCTURE (SEDIT::CONTEXT) + + (IL:* IL:|;;| "This code all stolen from SEDIT::MUTATE.") + + (LET* ((SEDIT::PROMPTWINDOW (SEDIT:GET-PROMPT-WINDOW SEDIT::CONTEXT)) + (SEDIT::SELECTION (IL:|fetch| SEDIT::SELECTION IL:|of| SEDIT::CONTEXT)) + (SEDIT::NODE (IL:|fetch| SEDIT::SELECT-NODE IL:|of| SEDIT::SELECTION))) + (COND + ((AND SEDIT::NODE (EQ (IL:|fetch| SEDIT::SELECT-TYPE IL:|of| SEDIT::SELECTION) + 'STRUCTURE) + (NULL (IL:|fetch| SEDIT::SELECT-START IL:|of| SEDIT::SELECTION))) + (UNLESS (SEDIT::DO-MUTATION SEDIT::CONTEXT SEDIT::NODE 'CONVERT) + (IL:|printout| SEDIT::PROMPTWINDOW T "Error during mutation. No changes made.")) + ) + (T (IL:|printout| SEDIT::PROMPTWINDOW T "Select whole structure to mutate.")))) + T) + +(DEFUN DEF-WARNING-BROWSER-DELETEDFN (BROWSER ITEM WINDOW) + (DECLARE (SPECIAL IL:PROMPTWINDOW)) + + (IL:* IL:|;;| "Record deletedness in the warning-entry itself, so that it dumps out properly.") + + (SETF (WE-DELETED (IL:FETCH IL:TIDATA IL:OF ITEM)) + (IL:FETCH IL:TIDELETED IL:OF ITEM)) + + (IL:* IL:|;;| "Ripple the consequences back thru the browsers...") + + (LET* ((WSTR (FIRST (IL:FETCH IL:TIDATA IL:OF ITEM))) + (FWB (IL:WINDOWPROP (FILE-CONTEXT-MENU (IL:WINDOWPROP WINDOW 'FILE-CONTEXT)) + 'WARNINGS-BROWSER))) + + (IL:* IL:|;;| "If all the instances of this message are deleted in this definition, line out the function name in the definitions browser.") + + (BLOCK FOO + (IL:TB.MAP.ITEMS BROWSER #'(LAMBDA (B I) + (DECLARE (IGNORE B)) + (LET ((DATA (IL:FETCH IL:TIDATA IL:OF ITEM))) + (WHEN (STRING= (FIRST DATA) + WSTR) + (UNLESS (WE-DELETED DATA) + + (IL:* IL:|;;| + "(FORMAT IL:PROMPTWINDOW \"~&Not all msg in def deleted.\")") + + (RETURN-FROM FOO NIL)))))) + + (IL:* IL:|;;| "If we didn't throw out of the block above, it's OK.") + + (LET* ((BS&IS (IL:WINDOWPROP WINDOW 'BROWSER-AND-ITEM)) + (WDB&I (CAR BS&IS)) + (FWB&I (CDR BS&IS)) + (B (CAR WDB&I)) + (I (CDR WDB&I))) + (SETF (FOURTH (IL:FETCH IL:TIDATA IL:OF I)) + T) (IL:* IL:\; " mark deleted.") + (IL:TB.DELETE.ITEM B I) + + (IL:* IL:|;;| + "If all the items in that browser are deleted, knock off the message from the fwb.") + + (IL:TB.MAP.ITEMS B #'(LAMBDA (B I) + (DECLARE (IGNORE B)) + (UNLESS (IL:FETCH IL:TIDELETED IL:OF I) + + (IL:* IL:|;;| + "(FORMAT IL:PROMPTWINDOW \"~&Not all msg deleted.\")") + + (RETURN-FROM FOO NIL)))) + (SETF (SECOND (IL:FETCH IL:TIDATA IL:OF (CDR FWB&I))) + T) (IL:* IL:\; " mark deleted.") + (IL:TB.DELETE.ITEM (CAR FWB&I) + (CDR FWB&I)))))) + +(DEFUN DEF-WARNING-BROWSER-SELECTEDFN (BROWSER ITEM WINDOW) + (LET* ((ECX (IL:WINDOWPROP (IL:WINDOWPROP WINDOW 'IL:MAINWINDOW) + 'SEDIT::EDIT-CONTEXT)) + (PROMPTWINDOW (SEDIT:GET-PROMPT-WINDOW ECX)) + (STRUC (SECOND (IL:FETCH IL:TIDATA IL:OF ITEM))) + (CONTEXT (IL:WINDOWPROP WINDOW 'FILE-CONTEXT)) + (OPTS (FILE-CONTEXT-OPTIONS CONTEXT)) + (*PACKAGE* (PROGV (CAR OPTS) + (CADR OPTS) + (FIND-PACKAGE *PACKAGE-FOR-RESULT-FILE*))) + (*READTABLE* (IL:\\GTREADTABLE "LISP" T))) + (SEDIT::SELECTION-DOWN ECX) + (LET ((TARGET (SEDIT::FIND-STRUCTURE STRUC (SEDIT::SUBNODE 1 (IL:FETCH SEDIT::ROOT + IL:OF ECX)) + NIL))) + (COND + (TARGET (IL:CLEARW PROMPTWINDOW) + (SEDIT::SELECT-NODE ECX TARGET T T) + (SEDIT::UPDATE ECX) + (SEDIT::NORMALIZE-SELECTION ECX)) + (T (WRITE-STRING "Oops! Structure not found." PROMPTWINDOW)))))) + +(DEFUN ENTER-NEW-MACRO-TEMPLATE (FORM) + + (IL:* IL:|;;| "Edits a dummy template for the macro operator in FORM.") + + (LET ((TEMPLATE (LIST 'DEFTEMPLATE (OR (AND FORM (CAR FORM)) + SEDIT::BASIC-GAP) + SEDIT::BODY-GAP)) + (EDITOR-NAME (CONCATENATE 'STRING "Macro template" (AND FORM " for ") + (AND FORM (STRING (CAR FORM))))) + (*PACKAGE* (FIND-PACKAGE "IL-CONVERT")) + (*READTABLE* (IL:\\GTREADTABLE "XCL" T))) + (FLET ((COMPLETION-OF-TEMPLATE-EDIT (SEDIT-CONTEXT STRUCTURE) + (WHEN (SYMBOLP (SECOND STRUCTURE)) + + (IL:* IL:|;;| "i.e. not a gap any more...") + + (PUSH (CDR STRUCTURE) + *USER-ADDED-TEMPLATES*) + (PUSH (CDR STRUCTURE) + *WALKER-TEMPLATES*)))) + (SEDIT:SEDIT TEMPLATE `(:NAME ,EDITOR-NAME :TYPE :MACRO-TEMPLATE :COMPLETION-FN + ,#'COMPLETION-OF-TEMPLATE-EDIT))))) + +(DEFUN FILE-WARNING-BROWSER-DELETEDFN (BROWSER ITEM WINDOW) + + (IL:* IL:|;;| "Record deletedness in the warning-header itself, so that it dumps out properly.") + + (SETF (SECOND (IL:FETCH IL:TIDATA IL:OF ITEM)) + (IL:FETCH IL:TIDELETED IL:OF ITEM))) + +(DEFUN FILE-WARNING-BROWSER-SELECTEDFN (BROWSER ITEM WINDOW) + (LET* ((ENTRY (IL:FETCH IL:TIDATA IL:OF ITEM)) + (WARNING-STRING (CAR ENTRY)) + (DEF-ENTRIES (CDDR ENTRY)) + (WARNING-DEFS-BROWSER (IL:WINDOWPROP WINDOW 'WARNING-DEFS-BROWSER)) + (TBITEMS (MAPCAR #'(LAMBDA (X) + (IL:CREATE IL:TABLEITEM + IL:TIDATA IL:_ X + IL:TIDELETED IL:_ (FOURTH X))) + DEF-ENTRIES))) + (IF (NULL WARNING-DEFS-BROWSER) + (SETQ WARNING-DEFS-BROWSER (MAKE-WARNINGS-BROWSER + (IL:* IL:\; "") + TBITEMS WARNING-STRING WINDOW 'IL:RIGHT + #'(LAMBDA (TB ITEM WINDOW) + (DECLARE (IGNORE TB)) + (LET ((STUFF (IL:|fetch| IL:TIDATA IL:|of| + ITEM))) + (PRINC (SECOND STUFF) + WINDOW) + (WRITE-CHAR #\Space WINDOW) + (PRINC (FIRST STUFF) + WINDOW))) + :SELECTEDFN + 'WARNING-DEFINITIONS-BROWSER-SELECTEDFN :MAINWINDOWPROP + 'WARNING-DEFS-BROWSER)) + (IL:WINDOWPROP WARNING-DEFS-BROWSER 'IL:TITLE WARNING-STRING)) + (IL:TB.REPLACE.ITEMS (IL:WINDOWPROP WARNING-DEFS-BROWSER 'IL:TABLEBROWSER) + TBITEMS) + (IL:WINDOWPROP WARNING-DEFS-BROWSER 'BROWSER-AND-ITEM (CONS BROWSER ITEM)))) + +(DEFUN FS-WINDOW-ADD\'L-FILE-BROWSER (FS-WINDOW) + (OR (IL:WINDOWPROP FS-WINDOW 'ADD\'L-FILE-BROWSER) + (MAKE-WARNINGS-BROWSER NIL "Additional files" FS-WINDOW 'IL:TOP + #'(LAMBDA (TB ITEM WINDOW) + (PRINC (FIRST (IL:|fetch| IL:TIDATA IL:|of| ITEM)) + WINDOW)) + :SELECTEDFN + 'ADD\'L-FILE-SELECTEDFN :MAINWINDOWPROP 'ADD\'L-FILE-BROWSER))) + +(DEFUN FS-WINDOW-BROWSE-TRANSLATIONS (ITEM WINDOW BUTTONS) + (LET* ((BROWSER (IL:WINDOWPROP WINDOW 'TRANSLATION-BROWSER)) + (CONTEXT (IL:WINDOWPROP WINDOW 'FILE-CONTEXT)) + (OPTS (FILE-CONTEXT-OPTIONS CONTEXT)) + (PRINT-PACKAGE (PROGV (CAR OPTS) + (CADR OPTS) + (FIND-PACKAGE *PACKAGE-FOR-RESULT-FILE*))) + (PRINT-RDTBL (IL:\\GTREADTABLE "LISP" T)) + (TBITEMS (MAPCAR #'(LAMBDA (X) + (IL:CREATE IL:TABLEITEM + IL:TIDATA IL:_ X)) + (FILE-CONTEXT-DEFINITIONS CONTEXT)))) + (IF (NULL BROWSER) + (IL:WINDOWPROP (IL:* IL:\; "") + WINDOW + 'TRANSLATION-BROWSER + (SETQ BROWSER (MAKE-WARNINGS-BROWSER (IL:* IL:\; "") + TBITEMS "Translations" WINDOW 'IL:TOP + #'(LAMBDA (TB ITEM WINDOW) + (DECLARE (IGNORE TB)) + (LET ((*PRINT-LEVEL* 1) + (*PRINT-LENGTH* 3) + (*PACKAGE* PRINT-PACKAGE) + (*READTABLE* PRINT-RDTBL)) + (PRINC (IL:|fetch| IL:TIDATA IL:|of| + ITEM) + WINDOW))) + :SELECTEDFN + 'TRANSLATION-BROWSER-SELECTEDFN :MAINWINDOWPROP + 'TRANSLATION-BROWSER))) + (IL:TB.REPLACE.ITEMS (IL:WINDOWPROP BROWSER 'IL:TABLEBROWSER) + TBITEMS)))) + +(DEFUN FS-WINDOW-BROWSE-WARNINGS (FS-WINDOW) + (LET* ((FILE-CONTEXT (IL:WINDOWPROP FS-WINDOW 'FILE-CONTEXT)) + (BROWSER (IL:WINDOWPROP FS-WINDOW 'WARNINGS-BROWSER)) + (TBITEMS)) + (MAPHASH #'(LAMBDA (KEY STUFF) + (WHEN (STRINGP KEY) (IL:* IL:\; + "only want warning strings, not definition entries.") + (PUSH (IL:CREATE IL:TABLEITEM + IL:TIDATA IL:_ (CONS KEY STUFF) + IL:TIDELETED IL:_ (FIRST STUFF)) + TBITEMS))) + (FILE-CONTEXT-WARNINGS FILE-CONTEXT)) + (IF (NULL BROWSER) + (PROGN + (IL:* IL:|;;| "Create a new warnings browser window...") + + (SETQ BROWSER (MAKE-WARNINGS-BROWSER (IL:* IL:\; "") + TBITEMS + (CONCATENATE 'STRING "Warnings for " (STRING ( + FILE-CONTEXT-FILENAME + FILE-CONTEXT)) + ) + FS-WINDOW + 'IL:BOTTOM + #'(LAMBDA (TB ITEM WINDOW) + (DECLARE (IGNORE TB)) + (LET ((STUFF (IL:|fetch| IL:TIDATA IL:|of| + ITEM))) + (PRINC (FIRST STUFF) + WINDOW))) + :SELECTEDFN + 'FILE-WARNING-BROWSER-SELECTEDFN :DELETEDFN + 'FILE-WARNING-BROWSER-DELETEDFN :MAINWINDOWPROP + 'WARNINGS-BROWSER))) + + (IL:* IL:|;;| "Browser is already there: Reload it.") + + (IL:TB.REPLACE.ITEMS (IL:WINDOWPROP BROWSER 'IL:TABLEBROWSER) + TBITEMS)))) + +(DEFUN FS-WINDOW-DO-TRANSLATE (ITEM WINDOW BUTTONS) + (LET ((FILE-CONTEXT (IL:WINDOWPROP WINDOW 'FILE-CONTEXT)) + (BROWSER (IL:WINDOWPROP WINDOW 'WARNINGS-BROWSER))) + (WHEN (FILE-CONTEXT-WARNINGS FILE-CONTEXT) + (UNLESS (MENU-CHOOSE '(("Do it" T) + ("Abort" NIL)) + "Discard all warnings and re-translate?") + (RETURN-FROM FS-WINDOW-DO-TRANSLATE NIL)) + (IL:CLEARCLISPARRAY)) + (WHEN BROWSER (IL:CLOSEW BROWSER)) + (IL:WINDOWPROP *STANDARD-OUTPUT* 'IL:PAGEFULLFN 'IL:NILL) + (CONVERT-FILE-FOR-CONTEXT FILE-CONTEXT) + (IL:CLOSEW *STANDARD-OUTPUT*) + (WHEN (FILE-CONTEXT-WARNINGS FILE-CONTEXT) + (FS-WINDOW-BROWSE-WARNINGS WINDOW)))) + +(DEFUN FS-WINDOW-EDIT-OPTIONS (ITEM WINDOW BUTTONS) + (DECLARE (IGNORE ITEM BUTTONS)) + (LET ((EDWINDOW (IL:FREEMENU *OPTIONS-FREEMENU-DESCRIPTION* "Options"))) + (IL:ATTACHWINDOW EDWINDOW WINDOW 'IL:TOP 'IL:JUSTIFY 'IL:LOCALCLOSE) + (OPTIONS-EDITOR-REVERT NIL EDWINDOW NIL))) + +(DEFUN FS-WINDOW-ICONFN (WINDOW &OPTIONAL ICON IGNORE) + (OR ICON (CONCATENATE 'STRING (STRING (FILE-CONTEXT-FILENAME (IL:WINDOWPROP WINDOW 'FILE-CONTEXT)) + ) + " translation"))) + +(DEFUN FS-WINDOW-SAVE-CONTEXT (ITEM WINDOW BUTTONS) + + (IL:* IL:|;;| "1. Dump definitions. 2. Dump Options. 3. Dump Warnings, encoded as list of (Name Type Position-in-definitions Deleted) (String Deleted Encoding-of-fragment-position) ...) ") + + (LET* + ((CONTEXT (IL:WINDOWPROP WINDOW 'FILE-CONTEXT)) + (DEFAULT-FILENAME (IL:PACKFILENAME.STRING 'IL:NAME (FILE-CONTEXT-FILENAME CONTEXT) + 'IL:EXTENSION "PST")) + (FILENAME (PROMPT-FOR-FILENAME WINDOW "File name:" DEFAULT-FILENAME))) + + (IL:* IL:|;;| "default the type to \"FCX\"") + + (WITH-OPEN-FILE + (OUTSTREAM FILENAME :DIRECTION :OUTPUT :IF-EXISTS :NEW-VERSION) + (LET ((*PRINT-BASE* 10) + (*PRINT-CIRCLE* NIL) + (*PRINT-ARRAY* T) + (*PRINT-PRETTY* NIL) + (*READTABLE* (IL:\\GTREADTABLE "XCL" T)) + (*PACKAGE* (FIND-PACKAGE "XCL")) + (IL:**COMMENT**FLG NIL)) + (WRITE-CHAR #\( OUTSTREAM) + (PRIN1 ':FILENAME OUTSTREAM) + (PRINT (FILE-CONTEXT-FILENAME CONTEXT) + OUTSTREAM) + (PRINT ':DIRNAME OUTSTREAM) + (PRINT (FILE-CONTEXT-DIRNAME CONTEXT) + OUTSTREAM) + (PRINT ':DEFINITIONS OUTSTREAM) + (WRITE-CHAR #\( OUTSTREAM) + (MAPC #'(LAMBDA (D) + (PRINT D OUTSTREAM) + (TERPRI OUTSTREAM)) + (FILE-CONTEXT-DEFINITIONS CONTEXT)) + (WRITE-CHAR #\) OUTSTREAM) + (PRINT ':WARNINGS OUTSTREAM) + + (IL:* IL:|;;| "Dump the warnings as positions in the definitions structure.") + + (MAPHASH #'(LAMBDA (KEY VALUE) + (IF (STRINGP KEY) + (PRINT (LIST* KEY (FIRST VALUE) + (MAPCAR #'(LAMBDA (X) + (LIST (FIRST X) + (SECOND X) + NIL + (FOURTH X))))) + OUTSTREAM) + (PRINT (LIST* KEY (LOCATE-SUBEXPRESSION (FIRST VALUE) + (FILE-CONTEXT-DEFINITIONS CONTEXT)) + (MAPCAR #'(LAMBDA (WE) + (LIST (WE-STRING WE) + (LOCATE-SUBEXPRESSION + (WE-EXPRESSION WE) + (FIRST VALUE)) + (WE-DELETED WE))) + (CDR VALUE))) + OUTSTREAM))) + (FILE-CONTEXT-WARNINGS CONTEXT)) + (PRINT ':OPTIONS OUTSTREAM) + (PRINT (FILE-CONTEXT-OPTIONS CONTEXT) + OUTSTREAM) + (PRINT ':FUNCTION-CALLS OUTSTREAM) + (PRINT (FILE-CONTEXT-FUNCTION-CALLS CONTEXT) + OUTSTREAM) + (PRINT ':FREE-REFERENCES OUTSTREAM) + (PRINT (FILE-CONTEXT-FREE-REFERENCES CONTEXT) + OUTSTREAM) + (TERPRI OUTSTREAM) + (WRITE-CHAR #\) OUTSTREAM))))) + +(DEFUN FS-WINDOW-SELECT-NEXT-DEFINITION (ITEM WINDOW BUTTON) + + (IL:* IL:|;;| "Delete the earlier item and select the subsequent one.") + + (LET* ((BW (IL:WINDOWPROP WINDOW 'WARNINGS-BROWSER)) + (TB (IL:WINDOWPROP BW 'IL:TABLEBROWSER)) + (LASTITEM (GETF (IL:TB.USERDATA TB) + 'LAST-ITEM)) + (NUMBER (OR (AND LASTITEM (IL:|fetch| IL:TI# IL:|of| LASTITEM)) + 0)) + (NEXTITEM (IL:TB.NTH.ITEM TB (1+ NUMBER))) + (NEXTITEMBOTTOM (AND NEXTITEM (IL:TB.BOTTOM.OF.ITEM TB NEXTITEM)))) + (WHEN LASTITEM + (IL:TB.DELETE.ITEM TB LASTITEM) + (LET ((FN (GETF (IL:TB.USERDATA TB) + 'IL:DELETEDFN))) + (WHEN FN (FUNCALL FN TB LASTITEM WINDOW)))) + (UNLESS (NULL NEXTITEM) + (WHEN (IL:|fetch| IL:TIDELETED IL:|of| NEXTITEM) + + (IL:* IL:|;;| "Oops, keep looking.") + + (INCF NUMBER) (IL:* IL:\; "current \"nextitem\" #.") + (LOOP (SETQ NEXTITEM (IL:TB.NTH.ITEM TB (INCF NUMBER))) + (WHEN (NULL NEXTITEM) + + (IL:* IL:|;;| "Out of items... flush.") + + (RETURN-FROM FS-WINDOW-SELECT-NEXT-DEFINITION NIL)) + (UNLESS (IL:FETCH IL:TIDELETED IL:OF NEXTITEM) + (SETQ NEXTITEMBOTTOM (IL:TB.BOTTOM.OF.ITEM TB NEXTITEM)) + (RETURN)))) + (IL:BLTSHADE IL:BLACKSHADE BW IL:TB.LEFT.MARGIN NEXTITEMBOTTOM (IL:WINDOWPROP + BW + 'IL:WIDTH) + (IL:|fetch| IL:TBITEMHEIGHT IL:|of| TB) + 'IL:INVERT) + (LET ((FN (GETF (IL:TB.USERDATA TB) + 'IL:SELECTEDFN))) + (WHEN FN (FUNCALL FN TB NEXTITEM WINDOW))) + (SETF (GETF (IL:FETCH IL:TBUSERDATA IL:OF TB) + 'LAST-ITEM) + NEXTITEM) + (IL:BLTSHADE IL:BLACKSHADE BW IL:TB.LEFT.MARGIN NEXTITEMBOTTOM (IL:WINDOWPROP + BW + 'IL:WIDTH) + (IL:|fetch| IL:TBITEMHEIGHT IL:|of| TB) + 'IL:INVERT)))) + +(DEFUN FS-WINDOW-WRITE-TRANSLATION (ITEM WINDOW BUTTON) + (LET* ((CONTEXT (IL:WINDOWPROP WINDOW 'FILE-CONTEXT)) + (FILENAME (FILE-CONTEXT-FILENAME CONTEXT)) + (PROMPT-FILENAME (IL:PACKFILENAME.STRING 'IL:NAME FILENAME 'IL:EXTENSION "LISP" + 'IL:VERSION NIL)) + (REAL-FILENAME (PROMPT-FOR-FILENAME WINDOW "File name:" PROMPT-FILENAME))) + (FS-WINDOW-WRITE-TRANSLATION-INTERNAL CONTEXT REAL-FILENAME))) + +(DEFUN FS-WINDOW-WRITE-TRANSLATION-INTERNAL (CONTEXT FILENAME) + (LET* ((DEFS (FILE-CONTEXT-DEFINITIONS CONTEXT)) + (*PRINT-BASE* 10) + (IL:*PRINT-SEMICOLON-COMMENTS* T) + (*PACKAGE* (FIND-PACKAGE (GET-FILE-CONTEXT-OPTION '*PACKAGE-FOR-RESULT-FILE* CONTEXT))) + (*READTABLE* (IL:\\GTREADTABLE "XCL" T)) + (*PRINT-PRETTY* T) + (*PRINT-ARRAY* T) + (*PRINT-CASE* :DOWNCASE) + (IL:FILELINELENGTH 79) + (IL:**COMMENT**FLG NIL)) + (DECLARE (SPECIAL IL:PRETTYPRINTMACROS IL:**COMMENT**FLG IL:*PRINT-SEMICOLON-COMMENTS* + IL:FILELINELENGTH)) + (WITH-OPEN-FILE + (OUTSTREAM FILENAME :IF-EXISTS :NEW-VERSION :DIRECTION :OUTPUT :IF-DOES-NOT-EXIST :CREATE) + (IL:LINELENGTH 79 OUTSTREAM) + (PRINT '(LET ((*PACKAGE* *PACKAGE*)) + (IN-PACKAGE :INTERLISP :USE NIL :NICKNAMES '(:IL))) + OUTSTREAM) + (PRINT `(IN-PACKAGE ,(PACKAGE-NAME *PACKAGE*) + :USE + ,(MAPCAR 'PACKAGE-NAME (PACKAGE-USE-LIST *PACKAGE*))) + OUTSTREAM) + (TERPRI OUTSTREAM) + (WHEN (FILE-CONTEXT-EXPORTED-SYMS CONTEXT) + (LET ((ALIST NIL)) + (DOLIST (S (FILE-CONTEXT-EXPORTED-SYMS CONTEXT)) + (LET ((ASSOC (ASSOC (PACKAGE-NAME (SYMBOL-PACKAGE S)) + ALIST))) + (IF ASSOC + (PUSH S (CDR ASSOC)) + (PUSH (CONS (PACKAGE-NAME (SYMBOL-PACKAGE S)) + (CONS S NIL)) + ALIST)))) + (DOLIST (A ALIST) + (PRINT `(EXPORT (MAPCAR 'INTERN ',(MAPCAR 'STRING (CDR A))) + ,(STRING (CAR A))) + OUTSTREAM))) + (TERPRI OUTSTREAM)) + (DOLIST (FORM (EXPURGATE-EXTRANEOUS-PROGNS DEFS)) + (WHEN FORM + (PRINT FORM OUTSTREAM) + (TERPRI OUTSTREAM)))))) + +(DEFMACRO GET-FILE-CONTEXT-OPTION (OPTION CONTEXT) + `(IF ,CONTEXT + (NTH (POSITION ,OPTION (FIRST (FILE-CONTEXT-OPTIONS ,CONTEXT))) + (SECOND (FILE-CONTEXT-OPTIONS ,CONTEXT))) + + (IL:* IL:|;;| "If there's no file context, read out the \"default\" values.") + + (SYMBOL-VALUE ,OPTION))) + +(DEFUN INVERT-CALLER-LIST (CALLS-LIST) + (MAPCAN #'(LAMBDA (X) + (LET ((VALUE (MAPCAN #'(LAMBDA (Y) + (AND (MEMBER (CAR X) + (CDR Y)) + (LIST (CAR Y)))) + CALLS-LIST))) + (AND VALUE (CONS (CONS (CAR X) + VALUE) + NIL)))) + CALLS-LIST)) + +(DEFUN LOCATE-SUBEXPRESSION (SUB MAIN) + (IF (EQ SUB MAIN) + NIL + (LET ((POS (DO ((MTAIL MAIN (CDR MTAIL)) + (N 0 (1+ N))) + ((ATOM MTAIL) + (AND MTAIL (EQ SUB MTAIL))) + (WHEN (EQ SUB (CAR MTAIL)) + (RETURN (LIST N))) + (WHEN (EQ SUB MTAIL) + (RETURN N))))) + (OR POS (DO ((MTAIL MAIN (CDR MTAIL)) + M + (N 0 (1+ N))) + ((ATOM MTAIL)) + (AND (CONSP (SETQ M (CAR MTAIL))) + (LET ((SUB-N (LOCATE-SUBEXPRESSION SUB M))) + (AND SUB-N (RETURN (CONS N SUB-N))))) + (INCF N)))))) + +(DEFUN MAKE-WARNINGS-BROWSER (TABLEITEMS TITLE MAINWINDOW EDGE PRINTFN &KEY SELECTEDFN DELETEDFN + RIGHTBUTTONFN MAINWINDOWPROP) + (LET ((WINDOW (IL:DECODE.WINDOW.ARG '(0 . 0) + 300 100 TITLE NIL T))) + (IL:ATTACHWINDOW WINDOW MAINWINDOW EDGE 'IL:JUSTIFY 'IL:LOCALCLOSE) + + (IL:* IL:|;;| "Note side effect of installing TB in window...") + + (IL:REPLACE IL:TBUSERDATA IL:OF (IL:TB.MAKE.BROWSER TABLEITEMS WINDOW + (LIST 'IL:PRINTFN PRINTFN)) + IL:WITH (LIST 'IL:SELECTEDFN SELECTEDFN 'IL:DELETEDFN DELETEDFN 'IL:RIGHTBUTTONFN + RIGHTBUTTONFN)) + (IL:WINDOWPROP WINDOW 'IL:BUTTONEVENTFN 'WB.BUTTONEVENTFN) + (IL:WINDOWPROP WINDOW 'IL:RIGHTBUTTONFN 'WB.BUTTONEVENTFN) + + (IL:* IL:|;;| "Store it in main window...") + + (IL:WINDOWPROP MAINWINDOW MAINWINDOWPROP WINDOW) + (IL:WINDOWPROP WINDOW 'MAINWINDOWPROP MAINWINDOWPROP) + + (IL:* IL:|;;| "When the browser is closed, delete it from the main window.") + + (IL:WINDOWADDPROP WINDOW 'IL:CLOSEFN 'WB.CLOSEFN T) + WINDOW)) + +(DEFUN MAP-INTO-CONTEXT (FN SEQUENCE) + (LET ((CONTEXT *FILE-CONTEXT*)) + (DOLIST (ITEM SEQUENCE) + (LET ((*WARNINGS-MADE* NIL)) + (MULTIPLE-VALUE-BIND (CONVERSION CALLS FREEREFS) + (FUNCALL FN ITEM) + (COND + (CONTEXT (WHEN *WARNINGS-MADE* + + (IL:* IL:|;;| "Some warning was made during the conversion. Put the converted definition on the definition warning record so we can edit it.") + + (LET ((ELT (GETHASH (FIRST *WARNINGS-MADE*) + (FILE-CONTEXT-WARNINGS CONTEXT)))) + (UNLESS ELT (ERROR "Couldn't find entry for ~s." ELT)) + (SETF (FIRST ELT) + CONVERSION))) + + (IL:* IL:|;;| + "Put the converted definition on the definitions list.") + + (LET ((APPENDAGE (IF (EQ (FIRST CONVERSION) + 'PROGN) + (CDR CONVERSION) + (CONS CONVERSION NIL)))) + (IF (NULL (FILE-CONTEXT-DEFINITIONS-LAST-CONS CONTEXT)) + (SETF (FILE-CONTEXT-DEFINITIONS CONTEXT) + APPENDAGE + (FILE-CONTEXT-DEFINITIONS-LAST-CONS CONTEXT) + (LAST (FILE-CONTEXT-DEFINITIONS CONTEXT))) + (SETF (CDR (FILE-CONTEXT-DEFINITIONS-LAST-CONS CONTEXT)) + APPENDAGE + (FILE-CONTEXT-DEFINITIONS-LAST-CONS CONTEXT) + (LAST (FILE-CONTEXT-DEFINITIONS-LAST-CONS CONTEXT)))) + ) + (WHEN (AND CALLS (NOT (NULL (CDR CALLS)))) + (PUSH CALLS (FILE-CONTEXT-FUNCTION-CALLS CONTEXT))) + (WHEN (AND FREEREFS (NOT (NULL (CDR FREEREFS)))) + (PUSH FREEREFS (FILE-CONTEXT-FREE-REFERENCES CONTEXT))) + NIL) + (T CONVERSION))))))) + +(DEFUN MAPCAN-INTO-CONTEXT (HEAD FN SEQUENCE) + (MAP-INTO-CONTEXT #'(LAMBDA (S) + (CONS HEAD (MAPCAN FN S))) + (LIST SEQUENCE))) + +(DEFUN MENU-CHOOSE (ITEMS TITLE) + (IL:MENU (IL:|create| IL:MENU + IL:ITEMS IL:_ ITEMS + IL:TITLE IL:_ TITLE))) + +(DEFUN NEW-FILE-CONTEXT (NAME DIR-AND-HOST) + (LET* ((MENU (IL:FREEMENU *FILE-CONTEXT-FREEMENU-DESCRIPTION*)) + (CONTEXT (LET* ((MFE (GET NAME 'IL:MAKEFILE-ENVIRONMENT)) + (PKGFORM (AND MFE (GETF MFE :PACKAGE))) + (PKG (AND PKGFORM (FIND-PACKAGE (EVAL PKGFORM)))) + (*PACKAGE-FOR-RESULT-FILE* (IF PKG + (PACKAGE-NAME PKG) + *PACKAGE-FOR-RESULT-FILE*))) + (MAKE-FILE-CONTEXT :FILENAME NAME :DIRNAME DIR-AND-HOST :MENU MENU :OPTIONS + (LIST *TRANSLATOR-OPTIONS* (MAPCAR 'SYMBOL-VALUE *TRANSLATOR-OPTIONS* + )))))) + (IL:FM.CHANGELABEL (IL:FM.GETITEM 'FILENAME NIL MENU) + NAME MENU) + (IL:FM.CHANGELABEL (IL:FM.GETITEM 'DIRNAME NIL MENU) + DIR-AND-HOST MENU) + (PUSH CONTEXT *FILE-CONTEXTS*) + (IL:WINDOWPROP MENU 'FILE-CONTEXT CONTEXT) + (IL:WINDOWPROP MENU 'IL:ICONFN 'FS-WINDOW-ICONFN) + (IL:WINDOWADDPROP MENU 'IL:CLOSEFN #'(LAMBDA (W) + (LET ((FC (IL:WINDOWPROP W 'FILE-CONTEXT))) + (IL:UNINTERRUPTABLY + (SETQ *FILE-CONTEXTS* + (DELETE (FILE-CONTEXT-FILENAME + FC) + *FILE-CONTEXTS* :TEST + 'EQ :KEY + 'FILE-CONTEXT-FILENAME))) + (SETF (FILE-CONTEXT-MENU FC) + NIL)) + (IL:WINDOWPROP W 'FILE-CONTEXT NIL))) + (IL:MOVEW MENU (IL:GETBOXPOSITION (IL:WINDOWPROP MENU 'IL:WIDTH) + (IL:WINDOWPROP MENU 'IL:HEIGHT))) + (IL:OPENW MENU) + CONTEXT)) + +(DEFUN NTH-SUBEXPRESSION (LOCATOR EXP) + (DOLIST (N LOCATOR) + (SETQ EXP (NTH N EXP))) + EXP) + +(DEFUN OPTIONS-EDITOR-ACCEPT (ITEM WINDOW BUTTONS) + (DECLARE (IGNORE ITEM BUTTONS)) + (LET ((CONTEXT (IL:WINDOWPROP (IL:WINDOWPROP WINDOW 'IL:MAINWINDOW) + 'FILE-CONTEXT))) + + (IL:* IL:|;;| "Go thru and check out any fields with validation fns.") + + (DOLIST (ID *TRANSLATOR-OPTIONS*) + (LET* ((ITEM (IL:FM.GETITEM ID NIL WINDOW)) + (VALFN (AND ITEM (IL:FM.ITEMPROP ITEM 'VALIDATION-FN)))) + (WHEN VALFN + (LET ((VALUE (ECASE (IL:FM.ITEMPROP ITEM 'TYPE) + (IL:STATE (IL:FM.ITEMPROP ITEM 'IL:STATE)) + (IL:EDIT (IL:FM.ITEMPROP ITEM 'IL:LABEL))))) + (MULTIPLE-VALUE-BIND (VALID CORRECTED) + (FUNCALL VALFN VALUE) + (UNLESS VALID + (FORMAT (IL:GETPROMPTWINDOW WINDOW 1) + "Bad value ~a." VALUE) + (IL:FM.EDITITEM ITEM WINDOW) + (RETURN-FROM OPTIONS-EDITOR-ACCEPT NIL)) + (ECASE (IL:FM.ITEMPROP ITEM 'TYPE) + (IL:STATE (IL:FM.ITEMPROP ITEM 'IL:STATE CORRECTED)) + (IL:EDIT (IL:FM.ITEMPROP ITEM 'IL:LABEL CORRECTED)))))))) + + (IL:* IL:|;;| "Set values now...") + + (DOLIST (ID *TRANSLATOR-OPTIONS*) + (LET* ((ITEM (OR (IL:FM.GETITEM ID NIL WINDOW) + (IL:FM.NWAYPROP WINDOW ID 'IL:STATE) + (ERROR "No item or NWAY collection named ~s." ID))) + (VALUE (ECASE (IL:FM.ITEMPROP ITEM 'TYPE) + (IL:NWAY (IL:FM.ITEMPROP ITEM 'IL:ID)) + (IL:STATE (IL:FM.ITEMPROP ITEM 'IL:STATE)) + (IL:EDIT (IL:FM.ITEMPROP ITEM 'IL:LABEL))))) + (IF CONTEXT + (SETF (NTH (POSITION ID (FIRST (FILE-CONTEXT-OPTIONS CONTEXT))) + (SECOND (FILE-CONTEXT-OPTIONS CONTEXT))) + VALUE) + + (IL:* IL:|;;| + "If no file context, set the default value. The ID is the same as the variable name.") + + (SET ID VALUE))))) + (IL:CLOSEW WINDOW)) + +(DEFUN OPTIONS-EDITOR-BROWSE-TEMPLATES (ITEM WINDOW BUTTON) + (LET ((ITEMS (MAPCAR #'(LAMBDA (X) + (IL:CREATE IL:TABLEITEM + IL:TIDATA IL:_ (CAR X))) + *USER-ADDED-TEMPLATES*)) + (BW (IL:WINDOWPROP WINDOW 'TEMPLATE-BROWSER))) + (IF BW + (IL:TB.REPLACE.ITEMS (IL:WINDOWPROP BW 'IL:TABLEBROWSER) + ITEMS) + (IL:WINDOWADDPROP (MAKE-WARNINGS-BROWSER ITEMS "CL Macro Templates" WINDOW 'IL:RIGHT + #'(LAMBDA (BROWSER ITEM WINDOW) + (PRINC (IL:FETCH IL:TIDATA IL:OF ITEM) + WINDOW)) + :SELECTEDFN + 'TEMPLATE-BROWSER-SELECTEDFN :MAINWINDOWPROP 'TEMPLATE-BROWSER) + 'IL:CLOSEFN + 'TEMPLATE-BROWSER-CLOSEFN T)))) + +(DEFUN OPTIONS-EDITOR-BROWSE-TRANSLATOR-MACROS (ITEM WINDOW BUTTON) + (LET ((ITEMS (MAPCAR #'(LAMBDA (X) + (IL:CREATE IL:TABLEITEM + IL:TIDATA IL:_ X)) + *USER-ADDED-TRANSLATOR-MACROS*)) + (BW (IL:WINDOWPROP WINDOW 'TRANSMACRO-BROWSER))) + (IF BW + (IL:TB.REPLACE.ITEMS (IL:WINDOWPROP BW 'IL:TABLEBROWSER) + ITEMS) + (IL:WINDOWADDPROP (MAKE-WARNINGS-BROWSER ITEMS "IL Translator Macros" WINDOW 'IL:RIGHT + #'(LAMBDA (BROWSER ITEM WINDOW) + (PRINC (IL:FETCH IL:TIDATA IL:OF ITEM) + WINDOW)) + :SELECTEDFN + 'TRANSMACRO-BROWSER-SELECTEDFN :MAINWINDOWPROP + 'TRANSMACRO-BROWSER) + 'IL:CLOSEFN + 'TRANSMACRO-BROWSER-CLOSEFN T)))) + +(DEFUN OPTIONS-EDITOR-CLOSEW (ITEM WINDOW BUTTON) + (DECLARE (IGNORE ITEM BUTTON)) + (IL:CLOSEW WINDOW)) + +(DEFUN OPTIONS-EDITOR-NEW-TEMPLATE (ITEM WINDOW BUTTON) + (ENTER-NEW-MACRO-TEMPLATE NIL)) + +(DEFUN OPTIONS-EDITOR-NEW-TRANSLATOR-MACRO (ITEM WINDOW BUTTON) + + (IL:* IL:|;;| "Is the completion function really doing this the right way?!") + + (LET ((TEMPLATE (LIST 'IL-DEFCONV SEDIT::BASIC-GAP SEDIT::ARGS-GAP SEDIT::BODY-GAP)) + (EDITOR-NAME "Translator Macro") + (*PACKAGE* (FIND-PACKAGE "IL-CONVERT")) + (*READTABLE* (IL:\\GTREADTABLE "XCL" T))) + (FLET ((COMPLETION-OF-TRANSLATOR-MACRO-EDIT (SEDIT-CONTEXT STRUCTURE) + (UNLESS (SOME #'(LAMBDA (M) + (TYPEP M 'SEDIT::GAP)) + STRUCTURE) + (PUSH (SECOND STRUCTURE) + *USER-ADDED-TRANSLATOR-MACROS*) + (EVAL STRUCTURE)))) + (SEDIT:SEDIT TEMPLATE `(:NAME ,EDITOR-NAME :TYPE :MACRO-TEMPLATE :COMPLETION-FN + ,#'COMPLETION-OF-TRANSLATOR-MACRO-EDIT))))) + +(DEFUN OPTIONS-EDITOR-REVERT (ITEM WINDOW BUTTONS) + (DECLARE (IGNORE ITEM BUTTONS)) + (LET* ((CONTEXT (IL:WINDOWPROP (IL:WINDOWPROP WINDOW 'IL:MAINWINDOW) + 'FILE-CONTEXT))) + (DOLIST (ID *TRANSLATOR-OPTIONS*) + (LET* ((VALUE (GET-FILE-CONTEXT-OPTION ID CONTEXT)) + (ITEM (OR (IL:FM.GETITEM ID NIL WINDOW) + (IL:FM.NWAYPROP WINDOW ID 'IL:INITSTATE) + (ERROR "No item or NWAY collection named ~s." ID)))) + (WHEN ITEM + (ECASE (IL:FM.ITEMPROP ITEM 'TYPE) + (IL:NWAY (IL:FM.CHANGESTATE ID (IL:FM.GETITEM VALUE NIL WINDOW) + WINDOW)) + (IL:STATE + (IL:FM.ITEMPROP ITEM 'IL:STATE VALUE) + + (IL:* IL:|;;| "Yeah, yucky code duplication...") + + (ECASE (IL:FM.ITEMPROP ITEM 'IL:CHANGESTATE) + (YESNOCHANGESTATE (IL:FM.CHANGELABEL ITEM (IF VALUE + "Yes" + "No") + WINDOW)))) + (IL:EDIT (IL:FM.CHANGELABEL ITEM VALUE WINDOW)))))))) + +(DEFUN PACKAGE-VALIDATIONFN (NAME) + (LET ((PKG (FIND-PACKAGE NAME))) + (IF PKG + (VALUES T (PACKAGE-NAME PKG)) + (VALUES NIL NIL)))) + +(DEFUN PARSE-FILENAME-FOR-FILE-CONTEXT (FILENAME) + (LET* ((PLIST (IL:UNPACKFILENAME.STRING FILENAME)) + (HOST (GETF PLIST 'IL:HOST)) + (DIR (GETF PLIST 'IL:DIRECTORY)) + (NAME (GETF PLIST 'IL:NAME)) + (TYPE (GETF PLIST 'TYPE)) + (VERSION (GETF PLIST 'IL:VERSION)) + (DIRSTRING (CONCATENATE 'STRING (AND HOST "{") + HOST + (AND HOST "}") + (AND DIR "<") + DIR + (AND DIR ">"))) + (NAMESTRING (IL:MKATOM (NSTRING-UPCASE (CONCATENATE 'STRING NAME (AND TYPE ".") + TYPE + (AND VERSION ";") + VERSION))))) + (LIST NAMESTRING DIRSTRING))) + +(DEFUN PROMPT-FOR-FILENAME (WINDOW &OPTIONAL (PROMPT "File name: ") + (DEFAULT "")) + (LET ((PW (IL:GETPROMPTWINDOW WINDOW 1)) + (OLDTTYPROCESS (IL:TTY.PROCESS (IL:THIS.PROCESS))) + (OLDTTYDISPLAYSTREAM)) + (IL:CLEARW PW) + (IL:OPENW PW) + (SETQ OLDTTYDISPLAYSTREAM (IL:TTYDISPLAYSTREAM PW)) + (UNWIND-PROTECT + (IL:PROMPTFORWORD PROMPT DEFAULT) + (IL:TTYDISPLAYSTREAM OLDTTYDISPLAYSTREAM) + (IL:TTY.PROCESS OLDTTYPROCESS) + (IL:REMOVEPROMPTWINDOW WINDOW)))) + +(DEFUN RECORD-WARNING (C) + + (IL:* IL:|;;| "This is a handler for the WARNING condition type. We record the warning and then let it be printed.") + + (LET* ((STR (WRITE-TO-STRING C :ESCAPE NIL)) + (FC *FILE-CONTEXT*) + (DN *CURRENT-DEFINITION*) + (WARNING-RECORD (LIST STR *CURRENT-EXPRESSION* NIL)) + TEMP) + + (IL:* IL:|;;| "Record the definition name indexed by string...") + + (LET* ((DEFKEY (CONS DN *CURRENT-DEFINITION-TYPE*)) + (STRINGELT (GETHASH STR (FILE-CONTEXT-WARNINGS FC))) + (DEFELT (GETHASH DEFKEY (FILE-CONTEXT-WARNINGS FC)))) + (WHEN DN (PUSHNEW DEFKEY *WARNINGS-MADE*)) + (IF (NULL STRINGELT) + (SETF (GETHASH STR (FILE-CONTEXT-WARNINGS FC)) + (LIST NIL (LIST DN *CURRENT-DEFINITION-TYPE* NIL NIL))) + (UNLESS (FIND-IF #'(LAMBDA (X) + (AND (EQ DN (FIRST X)) + (EQUAL *CURRENT-DEFINITION-TYPE* (SECOND X)))) + (CDR STRINGELT)) + (PUSH (LIST DN *CURRENT-DEFINITION-TYPE* *CURRENT-EXPRESSION* NIL) + (CDDR STRINGELT)))) + + (IL:* IL:|;;| "record the expression and warning string indexed by defname.") + + (IF (NULL DEFELT) + (SETF (GETHASH DEFKEY (FILE-CONTEXT-WARNINGS FC)) + (LIST NIL (LIST STR *CURRENT-EXPRESSION* NIL))) + (PUSH (LIST STR *CURRENT-EXPRESSION* NIL) + (CDR DEFELT))))) + NIL) + +(DEFUN TEMPLATE-BROWSER-CLOSEFN (W) + (LET* ((TB (IL:WINDOWPROP W 'IL:TABLEBROWSER)) + (NDEL (IL:TB.NUMBER.OF.ITEMS TB 'IL:DELETED))) + (WHEN (PLUSP NDEL) + (WHEN (MENU-CHOOSE '(("Yes" T) + ("No" NIL)) + "Expunge deleted items?") + (IL:TB.MAP.DELETED.ITEMS TB #'(LAMBDA (BROWSER ITEM) + (IL:UNINTERRUPTABLY + (SETQ *USER-ADDED-TEMPLATES* + (DELETE (IL:FETCH IL:TIDATA + IL:OF ITEM) + *USER-ADDED-TEMPLATES* :KEY + 'CAR) + *WALKER-TEMPLATES* + (DELETE (IL:FETCH IL:TIDATA + IL:OF ITEM) + *WALKER-TEMPLATES* :KEY + 'CAR))))))))) + +(DEFUN TEMPLATE-BROWSER-SELECTEDFN (BROWSER ITEM WINDOW) + + (IL:* IL:|;;| "Edits a dummy template for the macro operator in FORM.") + + (LET* ((NAME (IL:FETCH IL:TIDATA IL:OF ITEM)) + (REAL-TEMPLATE (ASSOC NAME *USER-ADDED-TEMPLATES*)) + (VISIBLE-TEMPLATE (CONS 'DEFTEMPLATE REAL-TEMPLATE)) + (EDITOR-NAME (CONCATENATE 'STRING "Macro template" (AND NAME " for ") + (AND NAME (STRING NAME))))) + (FLET ((COMPLETION-OF-TEMPLATE-EDIT (SEDIT-CONTEXT STRUCTURE) + (SETF (CDR REAL-TEMPLATE) + (CDDR STRUCTURE)))) + (SEDIT:SEDIT VISIBLE-TEMPLATE `(:NAME ,EDITOR-NAME :TYPE :MACRO-TEMPLATE + :COMPLETION-FN #'COMPLETION-OF-TEMPLATE-EDIT))))) + +(DEFUN TRANSLATION-BROWSER-SELECTEDFN (BROWSER ITEM WINDOW) + (LET* ((DEF-BODY (IL:FETCH IL:TIDATA IL:OF ITEM)) + (CONTEXT (IL:WINDOWPROP (IL:MAINWINDOW (IL:MAINWINDOW WINDOW)) + 'FILE-CONTEXT)) + (OPTS (FILE-CONTEXT-OPTIONS CONTEXT)) + (*PACKAGE* (PROGV (CAR OPTS) + (CADR OPTS) + (FIND-PACKAGE *PACKAGE-FOR-RESULT-FILE*))) + (*READTABLE* (IL:\\GTREADTABLE "LISP" T))) + (FLET ((COMPLETION-OF-DEFINITION-EDIT (SEDIT-CONTEXT STRUCTURE) + (UNLESS (EQ STRUCTURE DEF-BODY) + + (IL:* IL:|;;| "Root cons changed; bash old one with new contents.") + + (SETF (CAR DEF-BODY) + (CAR STRUCTURE) + (CDR DEF-BODY) + (CDR STRUCTURE))))) + (SEDIT:SEDIT DEF-BODY `(:TYPE :CONVERSION :COMPLETION-FN + #'COMPLETION-OF-DEFINITION-EDIT :ENVIRONMENT + ,*DEF-EDITOR-SEDIT-ENVIRONMENT* IL:DONTWAIT T) + NIL)))) + +(DEFUN TRANSLATOR-EDIT-DEFAULT-OPTIONS (ITEM WINDOW BUTTONS) + (DECLARE (IGNORE ITEM BUTTONS)) + (LET ((EDWINDOW (IL:FREEMENU *DEFAULT-OPTIONS-FREEMENU-DESCRIPTION* "Default Translator Options")) + ) + (IL:ATTACHWINDOW EDWINDOW WINDOW 'IL:TOP 'IL:JUSTIFY 'IL:LOCALCLOSE) + (OPTIONS-EDITOR-REVERT NIL EDWINDOW NIL))) + +(DEFUN TRANSLATOR-NEW-FILE-CONTEXT (ITEM WINDOW BUTTONS) + (LET* ((STRING (NSTRING-UPCASE (PROMPT-FOR-FILENAME WINDOW))) + (PLIST (IL:UNPACKFILENAME STRING)) + (FILENAME (GETF PLIST 'IL:NAME)) + (DIR (GETF PLIST 'IL:DIRECTORY)) + (HOST (GETF PLIST 'IL:HOST)) + (DIR-AND-HOST (IL:PACKFILENAME.STRING 'IL:HOST HOST 'IL:DIRECTORY DIR))) + (TRANSLATOR-NEW-FILE-CONTEXT-INTERNAL FILENAME DIR-AND-HOST))) + +(DEFUN TRANSLATOR-NEW-FILE-CONTEXT-INTERNAL (FILENAME DIR-AND-HOST) + (LET* ((FILEBITS (AND (GET FILENAME 'IL:FILE) + (IL:ADDFILE FILENAME))) + (FULLNAME (OR (AND DIR-AND-HOST (CONCATENATE 'STRING (STRING DIR-AND-HOST) + (STRING FILENAME))))) + (FILEPROP (AND FILEBITS (CDDR FILEBITS))) + (LOADTYPE (AND FILEPROP (IL:|fetch| IL:LOADTYPE IL:|of| FILEPROP)))) + (WHEN (OR (NULL FILEBITS) + (MEMBER LOADTYPE '(IL:LOADCOMP IL:|Compiled| IL:|compiled| IL:|loadfns|))) + (UNLESS (MENU-CHOOSE '(("Load it 'PROP'" T) + ("Abort" NIL)) + (CONCATENATE 'STRING "File " (STRING FILENAME) + " is not fully resident")) + (RETURN-FROM TRANSLATOR-NEW-FILE-CONTEXT-INTERNAL NIL)) + + (IL:* IL:|;;| "Note, it's STRING not FILENAME here so we get the directory.") + + (IL:LOAD FULLNAME 'IL:PROP)) + (NEW-FILE-CONTEXT FILENAME DIR-AND-HOST))) + +(DEFUN TRANSLATOR-NOTE-ADDITIONAL-FILE (FILE &OPTIONAL (CONTEXT *FILE-CONTEXT*)) + (LET* ((BROWSER-WINDOW (FS-WINDOW-ADD\'L-FILE-BROWSER *TRANSLATOR-MAIN-MENU*)) + (TB (IL:WINDOWPROP BROWSER-WINDOW 'IL:TABLEBROWSER)) + (PLIST (IL:UNPACKFILENAME FILE)) + (DIR (GETF PLIST 'IL:DIRECTORY)) + (HOST (GETF PLIST 'IL:HOST)) + (NAME (GETF PLIST 'IL:NAME)) + (DIR-AND-HOST (OR (AND (OR DIR HOST) + (IL:PACKFILENAME.STRING 'IL:HOST HOST 'IL:DIRECTORY DIR)) + (FILE-CONTEXT-DIRNAME CONTEXT)))) + (UNLESS (OR (IL:TB.FIND.ITEM TB #'(LAMBDA (IGNORE TI) + (EQ NAME (FIRST (IL:FETCH IL:TIDATA + IL:OF TI))))) + (FIND NAME *FILE-CONTEXTS* :TEST 'EQ :KEY 'FILE-CONTEXT-FILENAME)) + (LET ((NEWITEM (IL:CREATE IL:TABLEITEM + IL:TIDATA IL:_ (LIST NAME DIR-AND-HOST) + IL:TIUNDELETABLE IL:_ T))) + (IL:TB.INSERT.ITEM TB NEWITEM) + (IL:TB.NORMALIZE.ITEM TB NEWITEM))))) + +(DEFUN TRANSLATOR-READ-SAVED-CONTEXT (ITEM WINDOW BUTTON) + (LET ((FILENAME (PROMPT-FOR-FILENAME WINDOW))) + (WITH-OPEN-FILE + (INSTREAM FILENAME :IF-DOES-NOT-EXIST NIL) + (LET* ((*PRINT-BASE* 10) + (*PRINT-CIRCLE* NIL) + (*PRINT-ARRAY* T) + (*PRINT-PRETTY* NIL) + (*READTABLE* (IL:\\GTREADTABLE "XCL" T)) + (*PACKAGE* (FIND-PACKAGE "XCL")) + (ARGS (READ INSTREAM)) + (CONTEXT (APPLY 'MAKE-FILE-CONTEXT ARGS))) + + (IL:* IL:|;;| "Go thru the warnings and re-constitute them...") + + (MAPHASH #'(LAMBDA (K V) + (WHEN (CONSP K) + (LET ((DB (FIRST V))) + (WHEN (AND (LISTP DB) + (INTEGERP (FIRST DB))) + (SETF (FIRST V) + (NTH-SUBEXPRESSION DB (FILE-CONTEXT-DEFINITIONS + CONTEXT)))) + (DOLIST (ENTRY (CDR V)) + (WHEN (AND (LISTP ENTRY) + (INTEGERP (FIRST ENTRY))) + (SETF (WE-EXPRESSION ENTRY) + (NTH-SUBEXPRESSION (WE-EXPRESSION ENTRY) + DB))))))) + (FILE-CONTEXT-WARNINGS CONTEXT)))))) + +(DEFUN TRANSMACRO-BROWSER-CLOSEFN (W) + + (IL:* IL:|;;| "This doesn't delete t.m.s other than IL-DEFCONV ones yet.") + + (LET ((TB (IL:WINDOWPROP W 'IL:TABLEBROWSER))) + (WHEN (AND (PLUSP (IL:TB.NUMBER.OF.ITEMS TB 'IL:DELETED)) + (MENU-CHOOSE '(("Yes" T) + ("No" NIL)) + "Expunge deleted items?")) + (IL:TB.MAP.DELETED.ITEMS (IL:* IL:\; "") + TB + #'(LAMBDA (I) + (LET ((NAME (IL:FETCH IL:TIDATA IL:OF I))) + (WHEN (EQ (CAR (IL:GETDEF NAME :FUNCTIONS 'IL:CURRENT '(IL:NODWIM + IL:NOCOPY))) + 'IL-DEFCONV) + + (IL:* IL:|;;| + "Actually the above wants to be some kind of MEMBER thing.") + + (IL:DELDEF NAME :FUNCTIONS) + (IL:UNINTERRUPTABLY + (SETQ *USER-ADDED-TRANSLATOR-MACROS* (DELETE NAME + *USER-ADDED-TRANSLATOR-MACROS* + )))))))))) + +(DEFUN TRANSMACRO-BROWSER-SELECTEDFN (BROWSER ITEM WINDOW) + (ED (IL:FETCH IL:TIDATA IL:OF ITEM) + (LIST :FUNCTIONS :DONTWAIT))) + +(DEFUN UNKNOWN-MACRO-FORM (FORM &AUX (NAME (CAR FORM))) + (CASE *UNKNOWN-MACRO-ACTION* + (:UM-SILENT FORM) + (:UM-WARN + (LET ((*CURRENT-EXPRESSION* FORM)) + (WARN "Macro form ~s not translated" (FIRST FORM))) + FORM) + (:UM-PROMPT (LET ((CHOICE (IL:MENU (IL:CREATE IL:MENU + IL:ITEMS IL:_ '(("Enter new template" :ENTER) + ("Edit this form with SEDIT" :EDIT) + ( + "Treat forms with this macro as function calls" + :FUNCTION) + ("Don't walk forms with this macro" + :QUOTE) + ("Warn for forms with this macro" + :WARN) + ("Leave this expression alone" + :LEAVE)) + IL:TITLE IL:_ (CONCATENATE 'STRING "Unknown macro " + (STRING NAME) + ":"))))) + (CASE CHOICE + (:QUOTE + + (IL:* IL:|;;| "Enter a template to quote everything...") + + (LET ((NEW (LIST 'REPEAT (LIST NIL)))) + (PUSH NEW *USER-ADDED-TEMPLATES*) + (PUSH NAME *USER-ADDED-TEMPLATES*) + (PUSH NEW *WALKER-TEMPLATES*) + (PUSH NAME *WALKER-TEMPLATES*) + (WALK-TEMPLATE FORM NEW))) + (:FUNCTION (LET ((NEW (LIST 'CALL 'REPEAT (LIST 'EVAL)))) + (PUSH NEW *USER-ADDED-TEMPLATES*) + (PUSH NAME *USER-ADDED-TEMPLATES*) + (PUSH NEW *WALKER-TEMPLATES*) + (PUSH NAME *WALKER-TEMPLATES*) + (WALK-TEMPLATE FORM NEW))) + (:WARN (LET* ((WARNING-STRING (CONCATENATE 'STRING "Unknown macro " + (STRING NAME))) + (NEW (LIST 'WARN WARNING-STRING))) + (PUSH NEW *USER-ADDED-TEMPLATES*) + (PUSH NAME *USER-ADDED-TEMPLATES*) + (PUSH NEW *WALKER-TEMPLATES*) + (PUSH NAME *WALKER-TEMPLATES*) + (WALK-TEMPLATE FORM NEW))) + (:LEAVE FORM) + (:EDIT (SEDIT:SEDIT FORM NIL NIL)) + (:ENTER + (ENTER-NEW-MACRO-TEMPLATE NAME) + (WALK-FORM-INTERNAL FORM))))))) + +(DEFUN WALKER-FIND-PARAMETER-LIST (DEFINITION) + (LET ((*WALKER-FIND-PARAMETER-LIST* T) + (*CURRENT-FUNCTION-CALLS* NIL)) + (CATCH 'PARAMETER-LIST + (WALK-FORM-INTERNAL DEFINITION) + NIL))) + +(DEFUN WARN-FOR-PARM-CHANGES (OLD NEW NAME CONTEXT) + + (IL:* IL:|;;| "Perhaps we should go over ALL contexts?") + + (LET + (CALLERS) + (DOLIST (F (FILE-CONTEXT-FUNCTION-CALLS CONTEXT)) + (WHEN (MEMBER NAME (CDR F) + :TEST + 'EQ) + (PUSH (CAR F) + CALLERS))) + + (IL:* IL:|;;| + "For each caller, hunt down each place that the victim is used and make a warning for it.") + + (LABELS ((FIND-IT (DEF CALLER VICTIM CONTEXT) + (LABELS ((FIND-IT-INTERNAL + (EXPRS CALLER VICTIM CONTEXT DEF) + (FLET ((ADD-WARNING-TO (CX CALLER EXPR STRING) + (LET ((WI (FIND CALLER (FILE-CONTEXT-WARNINGS CX) + :TEST + 'EQ :KEY 'CAAR))) + (IF WI + (PUSH (LIST STRING EXPR NIL) + (CDR WI)) + (PUSH (CONS (LIST CALLER "Function" DEF NIL) + (LIST (LIST STRING EXPR NIL))) + (FILE-CONTEXT-WARNINGS CX)))))) + (DOLIST (E EXPRS) + (WHEN (LISTP E) + (WHEN (EQ (CAR E) + VICTIM) + (ADD-WARNING-TO CONTEXT CALLER E (CONCATENATE + 'STRING + "Parameters of " + (STRING VICTIM) + " changed.") + DEF)) + (WHEN (CDR E) + (FIND-IT-INTERNAL (CDR E) + CALLER VICTIM CONTEXT DEF))))))) + (COND + ((MEMBER (CAR DEF) + '(EVAL-WHEN)) + (DOLIST (D (CDDR DEF)) + (FIND-IT D CALLER VICTIM))) + ((EQ (SECOND DEF) + CALLER) + (FIND-IT-INTERNAL (CDDR DEF) + CALLER VICTIM CONTEXT DEF)))))) + (DOLIST (C CALLERS) + (DOLIST (D (FILE-CONTEXT-DEFINITIONS CONTEXT)) + (FIND-IT D C NAME CONTEXT)))))) + +(DEFUN WARNING-DEFINITIONS-BROWSER-SELECTEDFN (BROWSER ITEM WINDOW) + (LET* ((ENTRY (IL:FETCH IL:TIDATA IL:OF ITEM)) + (DEF-NAME (FIRST ENTRY)) + (DEF-TYPE (SECOND ENTRY)) + (KEY (CONS DEF-NAME DEF-TYPE)) + (CONTEXT (IL:WINDOWPROP (IL:MAINWINDOW (IL:MAINWINDOW WINDOW)) + 'FILE-CONTEXT)) + (DEF-ENTRY (GETHASH KEY (FILE-CONTEXT-WARNINGS CONTEXT))) + (DEF-BODY (FIRST DEF-ENTRY)) + (WARNINGS (REST DEF-ENTRY)) + (OPTS (FILE-CONTEXT-OPTIONS CONTEXT)) + (*PACKAGE* (PROGV (CAR OPTS) + (CADR OPTS) + (FIND-PACKAGE *PACKAGE-FOR-RESULT-FILE*))) + (*READTABLE* (IL:\\GTREADTABLE "LISP" T)) + (EDITOR-NAME (CONCATENATE 'STRING "Converted " (STRING DEF-TYPE) + " " + (STRING DEF-NAME))) + (OLD-PARM-LIST (COPY-LIST (WALKER-FIND-PARAMETER-LIST DEF-BODY)))) + (FLET ((COMPLETION-OF-DEFINITION-EDIT (SEDIT-CONTEXT STRUCTURE) + (UNLESS (EQ STRUCTURE DEF-BODY) + + (IL:* IL:|;;| "Root cons changed; bash old one with new contents.") + + (SETF (CAR DEF-BODY) + (CAR STRUCTURE) + (CDR DEF-BODY) + (CDR STRUCTURE)) + + (IL:* IL:|;;| "Compare parameter-lists at this point.") + + (WHEN OLD-PARM-LIST + (LET ((NEW-PARM-LIST (WALKER-FIND-PARAMETER-LIST STRUCTURE))) + (COMPARE-PARAMETER-LISTS OLD-PARM-LIST NEW-PARM-LIST DEF-NAME + CONTEXT)))))) + (LET* ((WB (DEF-EDITOR-BROWSE-WARNINGS (IL:|fetch| SEDIT::DISPLAY-WINDOW + IL:|of| + (SEDIT:SEDIT DEF-BODY + `(:NAME ,EDITOR-NAME :TYPE + :CONVERSION :COMPLETION-FN + + #' + COMPLETION-OF-DEFINITION-EDIT + :ENVIRONMENT + , + *DEF-EDITOR-SEDIT-ENVIRONMENT* + IL:DONTWAIT T) + NIL)) + WARNINGS CONTEXT)) + (B&I (IL:WINDOWPROP WINDOW 'BROWSER-AND-ITEM))) + (IL:WINDOWPROP WB 'BROWSER-AND-ITEM (CONS (CONS BROWSER ITEM) + B&I)))))) + +(DEFUN WB.BUTTONEVENTFN (IL:WINDOW) + (IL:TOTOPW IL:WINDOW) + (LET (IL:FN) + (COND + ((IL:INSIDEP (IL:DSPCLIPPINGREGION NIL IL:WINDOW) + (IL:LASTMOUSEX IL:WINDOW) + (IL:LASTMOUSEY IL:WINDOW)) + (IL:TB.DO.UNLESS.BUSY IL:WINDOW (IL:FUNCTION WB.DO.ITEM.SELECTION))) + ((IL:LASTMOUSESTATE (IL:ONLY IL:RIGHT)) + (IL:DOWINDOWCOM IL:WINDOW)) + ((AND (IL:LASTMOUSESTATE (OR IL:LEFT IL:MIDDLE)) + (IL:SETQ IL:FN (IL:|fetch| (IL:TABLEBROWSER IL:TBTITLEEVENTFN) + IL:|of| (IL:WINDOWPROP IL:WINDOW 'IL:TABLEBROWSER)))) + (IL:TB.DO.UNLESS.BUSY IL:WINDOW IL:FN))))) + +(DEFUN WB.CLOSEFN (W) + (IL:WINDOWPROP (IL:WINDOWPROP W 'IL:MAINWINDOW) + (OR (IL:WINDOWPROP W 'MAINWINDOWPROP) + 'WARNINGS-BROWSER) + NIL) + (IL:WINDOWDELPROP W 'IL:CLOSEFN 'WB.CLOSEFN)) + +(DEFUN WB.DO.ITEM.SELECTION (WINDOW BROWSER) + (DECLARE (SPECIAL IL:PROMPTWINDOW)) + (LET ((SELECTIONREGION (IL:DSPCLIPPINGREGION NIL WINDOW)) + THISITEM LASTITEM LASTITEMBOTTOM LASTY LASTBUTTON) + (FLET ((INVERT-LASTITEM NIL (IL:BLTSHADE IL:BLACKSHADE WINDOW IL:TB.LEFT.MARGIN + LASTITEMBOTTOM (IL:WINDOWPROP WINDOW 'IL:WIDTH) + (IL:|fetch| IL:TBITEMHEIGHT IL:|of| BROWSER) + 'IL:INVERT))) + (LOOP (IL:GETMOUSESTATE) + (COND + ((NOT (IL:INSIDEP SELECTIONREGION (IL:LASTMOUSEX WINDOW) + (SETQ LASTY (IL:LASTMOUSEY WINDOW)))) + (WHEN LASTITEM + + (IL:* IL:|;;| "Erase old highlight") + + (INVERT-LASTITEM) + (SETQ LASTITEM NIL)) + + (IL:* IL:|;;| "I would like to just return here and let the next window take over, but current mouse arrangement means I'll never get control back unless user lets up on mouse") + + (COND + ((IL:LASTMOUSESTATE IL:UP) + (RETURN)) + (T (IL:BLOCK)))) + ((IL:LASTMOUSESTATE IL:UP) + + (IL:* IL:|;;| " Button released inside window...") + + (WHEN LASTITEM + + (IL:* IL:|;;| "Erase old highlight") + + (INVERT-LASTITEM)) + (WHEN LASTBUTTON + + (IL:* IL:|;;| + "Left: do edit. Middle: toggle deleted. Right: menu of things.") + + (CASE LASTBUTTON + (IL:LEFT (LET ((FN (GETF (IL:FETCH IL:TBUSERDATA IL:OF + BROWSER) + 'IL:SELECTEDFN))) + (WHEN FN (FUNCALL FN BROWSER LASTITEM WINDOW)))) + (IL:MIDDLE + (IF (IL:|fetch| IL:TIDELETED IL:|of| LASTITEM) + (IL:TB.UNDELETE.ITEM BROWSER LASTITEM) + (IL:TB.DELETE.ITEM BROWSER LASTITEM)) + (LET ((FN (GETF (IL:FETCH IL:TBUSERDATA IL:OF BROWSER) + 'IL:DELETEDFN))) + (WHEN FN (FUNCALL FN BROWSER LASTITEM WINDOW)))) + (IL:RIGHT (LET ((FN (GETF (IL:|fetch| IL:TBUSERDATA IL:|of| + BROWSER) + 'IL:RIGHTBUTTONFN))) + (WHEN FN (FUNCALL FN BROWSER LASTITEM WINDOW)))))) + (RETURN)) + (T (SETQ THISITEM (IL:TB.ITEM.FROM.YCOORD BROWSER LASTY)) + (UNLESS (EQ THISITEM LASTITEM) + (WHEN LASTITEM + + (IL:* IL:|;;| "Erase old highlight...") + + (INVERT-LASTITEM)) + (SETQ LASTITEM THISITEM LASTITEMBOTTOM (AND THISITEM ( + IL:TB.BOTTOM.OF.ITEM + BROWSER THISITEM) + )) + (WHEN THISITEM + + (IL:* IL:|;;| "Highlight new item...") + + (INVERT-LASTITEM))) + (COND + ((IL:LASTMOUSESTATE IL:LEFT) + (SETQ LASTBUTTON 'IL:LEFT)) + ((IL:LASTMOUSESTATE IL:MIDDLE) + (SETQ LASTBUTTON 'IL:MIDDLE)) + ((IL:LASTMOUSESTATE IL:RIGHT) + (SETQ LASTBUTTON 'IL:RIGHT))))))))) + +(DEFMACRO WITH-FILE-CONTEXT-OPTIONS (FC &BODY BODY) + `(XCL:HANDLER-BIND ((XCL:WARNING 'RECORD-WARNING)) + (PROGV (FIRST (FILE-CONTEXT-OPTIONS ,FC)) + (SECOND (FILE-CONTEXT-OPTIONS ,FC)) + ,@BODY))) + +(DEFUN YESNOCHANGESTATE (ITEM WINDOW BUTTON) + (LET ((NEWSTATE (NOT (IL:FM.ITEMPROP ITEM 'IL:STATE)))) + (IL:FM.ITEMPROP ITEM 'IL:STATE NEWSTATE) + (IL:FM.CHANGELABEL ITEM (IF NEWSTATE + "Yes" + "No") + WINDOW NIL))) + +(DEFVAR *TRANSLATOR-MAIN-MENU* (IL:FREEMENU *TRANSLATOR-CONTROL-FREEMENU-DESCRIPTION*)) + +(IL:TOTOPW *TRANSLATOR-MAIN-MENU*) +(IL:PUTPROPS IL:TRANSLATOR-ASSISTANT IL:COPYRIGHT ("ENVOS Corporation" 1989 1990)) +(IL:DECLARE\: IL:DONTCOPY + (IL:FILEMAP (NIL))) +IL:STOP