github.com/Interlisp.medley
1
0
Fork 0
mirror of synced 2026-05-09 17:16:58 +00:00
Code Issues Projects Releases Wiki Activity

Make (ARGLIST fn T) and (SMARTARGLIST fn T) a bit "smarter" with the atomic name of the arg for a LAMBDA nospread with a CCODEP definition.

Browse Source 
E.g., before (ARGLIST 'FONTCOPY T) returned U; now it returns FONTSPECS as in the CCODEP. Likewise for SMARTARGLIST.
This commit is contained in:
Matt Heffron
2026-05-08 23:59:31 -07:00
parent bbf9f73cda
commit 133f7b4969
2 changed files with 58 additions and 63 deletions
Download Patch File Download Diff File Expand all files Collapse all files

121
sources/LLINTERP
View File

@@ -1,19 +1,13 @@
(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
(DEFINE-FILE-INFO :PACKAGE "INTERLISP" :READTABLE "INTERLISP" :BASE 10)
(FILECREATED "30-Jun-2022 22:42:02" 
{DSK}<users>kaplan>local>medley3.5>working-medley>sources>LLINTERP.;4 120990
(FILECREATED " 8-May-2026 23:51:41" {DSK}<home>matt>Interlisp>medley>sources>LLINTERP.;2 120946
:PREVIOUS-DATE "30-Jun-2022 18:04:04"
{DSK}<users>kaplan>local>medley3.5>working-medley>sources>LLINTERP.;3)
:EDIT-BY "mth"
:CHANGES-TO (FNS \CCODEARGLIST)
:PREVIOUS-DATE "30-Jun-2022 22:42:02" {DSK}<home>matt>Interlisp>medley>sources>LLINTERP.;1)
(* ; "
Copyright (c) 1981-1988, 1990-1992, 1994-1995 by Venue & Xerox Corporation.
The following program was created in 1981 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 LLINTERPCOMS)
@@ -1541,7 +1535,8 @@ with the terms of said license.
(T (ERROR '"Args not available:" FN])
(\CCODEARGLIST
[LAMBDA (FNHD SMARTP) (* ; "Edited 10-May-88 12:18 by MASINTER")
[LAMBDA (FNHD SMARTP) (* ; "Edited 8-May-2026 23:44 by mth")
(* ; "Edited 10-May-88 12:18 by MASINTER")
(* ;; "Computes the arglist for raw code object FNHD. If SMARTP is true, we're allowed to return a Common Lisp arg list if we find one; otherwise, we have to comply with Interlisp arglist semantics.")
@@ -1556,53 +1551,55 @@ with the terms of said license.
(SETQ SIZE (fetch (FNHEADER NTSIZE) of FNHD))
[COND
((EQ [SETQ LOCALSIZE (- (FOLDLO (if (fetch (FNHEADER NATIVE) of FNHD)
then (- (fetch (FNHEADER STARTPC)
of FNHD)
4)
then (- (fetch (FNHEADER STARTPC) of FNHD)
4)
else (fetch (FNHEADER STARTPC) of FNHD))
BYTESPERWORD)
(SETQ ENDT (+ (fetch (FNHEADER OVERHEADWORDS) of T)
(COND
((EQ SIZE 0)
(* ;
 "No nametable, but there's a quad of zeros there anyway")
 "No nametable, but there's a quad of zeros there anyway")
WORDSPERQUAD)
(T (UNFOLD SIZE 2]
0) (* ; "Nothing extra here")
)
[(> LOCALSIZE WORDSPERCELL) (* ;
 "There is a second nametable between the first and the code.")
 "There is a second nametable between the first and the code.")
(SETQ IVARS (\CCODEIVARSCAN FNHD ENDT (FOLDLO LOCALSIZE 2]
((AND (LISTP (SETQ ENDT (\GETBASEPTR FNHD ENDT)))
(LISTP (CAR ENDT))) (* ;
 "It's exactly a pointer to debugging info, car of which is a stylized arglist")
 "It's exactly a pointer to debugging info, car of which is a stylized arglist")
(SETQ ENDT (if (AND (EQ (CAAR ENDT)
'&OPTIONAL)
(LISTGET (CDR ENDT)
:INTERLISP))
then (* ; "The &OPTIONAL, while strictly correct, is misleading, since it's technically true for ALL Interlisp functions.")
(CDAR ENDT)
'&OPTIONAL)
(LISTGET (CDR ENDT)
:INTERLISP))
then (* ; "The &OPTIONAL, while strictly correct, is misleading, since it's technically true for ALL Interlisp functions.")
(CDAR ENDT)
else (CAR ENDT)))
(RETURN (COND
(SMARTP ENDT)
(T (* ; "Note that if we got this far, function can't be a nospread (we caught this in the very first COND up above), which means there can't be any &key or &rest")
(for X in ENDT unless (EQ X '&OPTIONAL)
collect (COND
((STRINGP X) (* ;
 "Callers of ARGLIST are expecting to get something that would actually function as one")
(MKATOM X))
(T X]
(for X in ENDT unless (EQ X '&OPTIONAL) collect (COND
((STRINGP X)
(* ;
 "Callers of ARGLIST are expecting to get something that would actually function as one")
(MKATOM X))
(T X]
[COND
((< N 0) (* ;
 "Waited until now to see if there was a stored arglist, but we didn't find one--give up")
(RETURN 'U]
 "Waited until now to see if there was a stored arglist, but we didn't find one--give up")
(RETURN (COND
((AND (EQ 2 (fetch (FNHEADER ARGTYPE) of FNHD))
(SETQ IVARS (ASSOC 0 IVARS)))
(CDR IVARS))
(T 'U]
[COND
((NEQ SIZE 0) (* ; "Scan specials name table")
(SETQ IVARS (\CCODEIVARSCAN FNHD (fetch (FNHEADER OVERHEADWORDS) of T)
SIZE IVARS]
[SETQ IVARS (for I from 0 to (SUB1 N)
collect (OR (CDR (ASSOC I IVARS))
(PACK* '*ARG* I]
[SETQ IVARS (for I from 0 to (SUB1 N) collect (OR (CDR (ASSOC I IVARS))
(PACK* '*ARG* I]
(RETURN (SELECTQ (fetch (FNHEADER ARGTYPE) of FNHD)
(3 (CAR IVARS))
IVARS])
@@ -1745,33 +1742,31 @@ with the terms of said license.
(ADDTOVAR LAMA APPLY* \INTERPRETER)
)
(PUTPROPS LLINTERP COPYRIGHT ("Venue & Xerox Corporation" T 1981 1982 1983 1984 1985 1986 1987 1988
1990 1991 1992 1994 1995))
(DECLARE%: DONTCOPY
(FILEMAP (NIL (6409 23670 (\INTERPRETER 6419 . 11015) (\INTERPRETER1 11017 . 17585) (
\SETUP-COMPILED-CLOSURE-CALL 17587 . 22734) (\STKNAME 22736 . 23668)) (23699 29111 (\ENVCALL.UFN 23709
. 23841) (\SETUP-ENVIRONMENT-CALL 23843 . 29109)) (29150 34027 (EVAL 29160 . 29260) (\EVAL 29262 .
29472) (\EVALFORM 29474 . 30705) (\EVALFORMASLAMBDA 30707 . 30897) (\EVALOTHER 30899 . 31106) (APPLY
31108 . 31215) (APPLY* 31217 . 32332) (\CHECKAPPLY* 32334 . 33439) (\CKAPPLYARGS 33441 . 33784) (
DEFEVAL 33786 . 34025)) (35871 43460 (EVALV 35881 . 36090) (\EVALV1 36092 . 36247) (\EVALVAR 36249 .
36612) (BOUNDP 36614 . 36830) (SET 36832 . 37198) (\SETVAR 37200 . 37570) (SETQ 37572 . 38244) (
\STKSCAN 38246 . 41910) (\SETFVARSLOT 41912 . 43458)) (43494 56501 (PROG 43504 . 46020) (\PROG0 46022
. 49652) (\EVPROG1 49654 . 49857) (RETURN 49859 . 50400) (GO 50402 . 51217) (EVALA 51219 . 53148) (
\EVALA 53150 . 55743) (ERRORSET 55745 . 56350) (SI::ERRORSET-PRINT-FUNCTION 56352 . 56499)) (56560
69212 (LET 56570 . 58713) (LET* 58715 . 60863) (\LET0 60865 . 64525) (\LET* 64527 . 69210)) (69213
70789 (QUOTE 69223 . 69254) (AND 69256 . 69464) (OR 69466 . 69714) (PROGN 69716 . 69995) (COND 69997
. 70331) (\EVPROGN 70333 . 70546) (PROG1 70548 . 70787)) (71277 78168 (ENVEVAL 71287 . 71537) (
ENVAPPLY 71539 . 71796) (FUNCTION 71798 . 72028) (\FUNCT1 72030 . 74479) (\MAKEFUNARGFRAME 74481 .
76678) (STKEVAL 76680 . 76828) (STKAPPLY 76830 . 76999) (RETEVAL 77001 . 77605) (RETAPPLY 77607 .
78166)) (78289 85797 (BLIPVAL 78299 . 82200) (SETBLIPVAL 82202 . 84944) (BLIPSCAN 84946 . 85795)) (
85798 86493 (\REALFRAMEP 85808 . 86491)) (86869 96264 (RAIDCOMMAND 86879 . 90485) (RAIDSHOWFRAME 90487
. 90870) (RAIDSTACKCMD 90872 . 92053) (RAIDROOTFRAME 92055 . 92317) (PRINTADDRS 92319 . 92845) (
PRINTVA 92847 . 92992) (READVA 92994 . 93072) (READATOM 93074 . 93656) (READOCT 93658 . 94289) (
SHOWSTACKBLOCKS 94291 . 95537) (SHOWSTACKBLOCK1 95539 . 95690) (PRINCOPY 95692 . 95824) (NOSUCHATOM
95826 . 96262)) (96265 104893 (BACKTRACE 96275 . 96632) (\BACKTRACE 96634 . 97740) (\SCANFORNTENTRY
97742 . 99372) (\PRINTSTK 99374 . 99561) (\PRINTFRAME 99563 . 103546) (\PRINTBF 103548 . 104891)) (
107393 116737 (CCODEP 107403 . 107678) (EXPRP 107680 . 107939) (SUBRP 107941 . 107996) (FNTYP 107998
. 108758) (ARGTYPE 108760 . 109374) (NARGS 109376 . 109863) (ARGLIST 109865 . 111114) (\CCODEARGLIST
111116 . 115512) (\CCODEIVARSCAN 115514 . 116735)) (117687 119918 (CONSTANTS 117697 . 117988) (
CONSTANTEXPRESSIONP 117990 . 119916)))))
(FILEMAP (NIL (6111 23372 (\INTERPRETER 6121 . 10717) (\INTERPRETER1 10719 . 17287) (
\SETUP-COMPILED-CLOSURE-CALL 17289 . 22436) (\STKNAME 22438 . 23370)) (23401 28813 (\ENVCALL.UFN 23411
. 23543) (\SETUP-ENVIRONMENT-CALL 23545 . 28811)) (28852 33729 (EVAL 28862 . 28962) (\EVAL 28964 .
29174) (\EVALFORM 29176 . 30407) (\EVALFORMASLAMBDA 30409 . 30599) (\EVALOTHER 30601 . 30808) (APPLY
30810 . 30917) (APPLY* 30919 . 32034) (\CHECKAPPLY* 32036 . 33141) (\CKAPPLYARGS 33143 . 33486) (
DEFEVAL 33488 . 33727)) (35573 43162 (EVALV 35583 . 35792) (\EVALV1 35794 . 35949) (\EVALVAR 35951 .
36314) (BOUNDP 36316 . 36532) (SET 36534 . 36900) (\SETVAR 36902 . 37272) (SETQ 37274 . 37946) (
\STKSCAN 37948 . 41612) (\SETFVARSLOT 41614 . 43160)) (43196 56203 (PROG 43206 . 45722) (\PROG0 45724
. 49354) (\EVPROG1 49356 . 49559) (RETURN 49561 . 50102) (GO 50104 . 50919) (EVALA 50921 . 52850) (
\EVALA 52852 . 55445) (ERRORSET 55447 . 56052) (SI::ERRORSET-PRINT-FUNCTION 56054 . 56201)) (56262
68914 (LET 56272 . 58415) (LET* 58417 . 60565) (\LET0 60567 . 64227) (\LET* 64229 . 68912)) (68915
70491 (QUOTE 68925 . 68956) (AND 68958 . 69166) (OR 69168 . 69416) (PROGN 69418 . 69697) (COND 69699
. 70033) (\EVPROGN 70035 . 70248) (PROG1 70250 . 70489)) (70979 77870 (ENVEVAL 70989 . 71239) (
ENVAPPLY 71241 . 71498) (FUNCTION 71500 . 71730) (\FUNCT1 71732 . 74181) (\MAKEFUNARGFRAME 74183 .
76380) (STKEVAL 76382 . 76530) (STKAPPLY 76532 . 76701) (RETEVAL 76703 . 77307) (RETAPPLY 77309 .
77868)) (77991 85499 (BLIPVAL 78001 . 81902) (SETBLIPVAL 81904 . 84646) (BLIPSCAN 84648 . 85497)) (
85500 86195 (\REALFRAMEP 85510 . 86193)) (86571 95966 (RAIDCOMMAND 86581 . 90187) (RAIDSHOWFRAME 90189
. 90572) (RAIDSTACKCMD 90574 . 91755) (RAIDROOTFRAME 91757 . 92019) (PRINTADDRS 92021 . 92547) (
PRINTVA 92549 . 92694) (READVA 92696 . 92774) (READATOM 92776 . 93358) (READOCT 93360 . 93991) (
SHOWSTACKBLOCKS 93993 . 95239) (SHOWSTACKBLOCK1 95241 . 95392) (PRINCOPY 95394 . 95526) (NOSUCHATOM
95528 . 95964)) (95967 104595 (BACKTRACE 95977 . 96334) (\BACKTRACE 96336 . 97442) (\SCANFORNTENTRY
97444 . 99074) (\PRINTSTK 99076 . 99263) (\PRINTFRAME 99265 . 103248) (\PRINTBF 103250 . 104593)) (
107095 116821 (CCODEP 107105 . 107380) (EXPRP 107382 . 107641) (SUBRP 107643 . 107698) (FNTYP 107700
. 108460) (ARGTYPE 108462 . 109076) (NARGS 109078 . 109565) (ARGLIST 109567 . 110816) (\CCODEARGLIST
110818 . 115596) (\CCODEIVARSCAN 115598 . 116819)) (117771 120002 (CONSTANTS 117781 . 118072) (
CONSTANTEXPRESSIONP 118074 . 120000)))))
STOP