aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/ChangeLog20
-rw-r--r--src/boot/ast.boot14
-rw-r--r--src/boot/parser.boot7
-rw-r--r--src/boot/strap/ast.clisp106
-rw-r--r--src/boot/strap/parser.clisp5
-rw-r--r--src/boot/strap/tokens.clisp8
-rw-r--r--src/boot/tokens.boot1
-rw-r--r--src/interp/br-op1.boot4
-rw-r--r--src/interp/c-util.boot12
-rw-r--r--src/interp/cattable.boot2
-rw-r--r--src/interp/clam.boot8
-rw-r--r--src/interp/define.boot2
-rw-r--r--src/interp/i-coerfn.boot4
-rw-r--r--src/interp/i-output.boot2
-rw-r--r--src/interp/i-syscmd.boot2
-rw-r--r--src/interp/showimp.boot6
-rw-r--r--src/interp/sys-utility.boot3
-rw-r--r--src/interp/vmlisp.lisp10
18 files changed, 143 insertions, 73 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index ebc8a2a5..b94f4db7 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,5 +1,25 @@
2011-12-28 Gabriel Dos Reis <gdr@cs.tamu.edu>
+ * interp/vmlisp.lisp (SORTBY): Remove.
+ (QSORT): Likewise.
+ * interp/c-util.boot (formal?): Rename from isFormal. Avoid POSITION.
+ * interp/sys-utility.boot (sortBy): New.
+ * interp/br-op1.boot: Use it.
+ * interp/clam.boot: Likewise.
+ * interp/define.boot: Likewise.
+ * interp/i-output.boot: Likewise.
+ * interp/i-coerfn.boot: Likewise.
+ * interp/i-syscmd.boot: Likewise.
+ * interp/showimp.boot: Likewise.
+ * boot/tokens.boot: "<-" is now a token.
+ * boot/ast.boot (bfKeyArg): New.
+ (bfExpandKeys): Likewise.
+ (bfApplication): Use it.
+ * boot/parser.boot (bpKeyArg): New.
+ (bpAssign): Use it. Parse named arguments.
+
+2011-12-28 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
* boot/tokens.boot: Remove redundant renaming of REM.
loopBody and loopExit are not selectors.
* interp/i-output.boot: Include sys-utility.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 4a476189..656fdceb 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -72,6 +72,7 @@ structure %Ast ==
%Colon(%Symbol) -- :x
%QualifiedName(%Symbol,%Symbol) -- m::x
%DefaultValue(%Symbol,%Ast) -- opt. value for function param.
+ %Key(%Symbol,%Ast) -- k <- x
%Bracket(%Ast) -- [x, y]
%UnboundedSegment(%Ast) -- 3..
%BoundedSgement(%Ast,%Ast) -- 2..4
@@ -770,8 +771,19 @@ bfHas(expr,prop) ==
symbol? prop => ["GET",expr, quote prop]
bpSpecificErrorHere('"expected identifier as property name")
+bfKeyArg(k,x) ==
+ ['%Key,k,x]
+
+bfExpandKeys l ==
+ args := nil
+ while l is [a,:l] repeat
+ a is ['%Key,k,x] =>
+ args := [x,makeSymbol(stringUpcase symbolName k,'"KEYWORD"),:args]
+ args := [a,:args]
+ reverse! args
+
bfApplication(bfop, bfarg) ==
- bfTupleP bfarg => [bfop,:rest bfarg]
+ bfTupleP bfarg => [bfop,:bfExpandKeys rest bfarg]
[bfop,bfarg]
-- returns the meaning of x in the appropriate Boot dialect.
diff --git a/src/boot/parser.boot b/src/boot/parser.boot
index dde2bd3e..5c198129 100644
--- a/src/boot/parser.boot
+++ b/src/boot/parser.boot
@@ -858,6 +858,9 @@ bpAssign()==
bpEqPeek "GIVES" =>
bpRestore a
bpLambda() or bpTrap()
+ bpEqPeek "LARROW" =>
+ bpRestore a
+ bpKeyArg() or bpTrap()
true
bpRestore a
false
@@ -876,6 +879,10 @@ bpLambda() ==
(bpAssign() or bpTrap()) and
bpPush bfLambda(bpPop2(),bpPop1())
+bpKeyArg() ==
+ bpName() and bpEqKey "LARROW" and bpLogical() and
+ bpPush bfKeyArg(bpPop2(),bpPop1())
+
-- should only be allowed in sequences
bpExit()==
bpAssign() and (bpEqKey "EXIT" and
diff --git a/src/boot/strap/ast.clisp b/src/boot/strap/ast.clisp
index 3bf3ce53..b0c40086 100644
--- a/src/boot/strap/ast.clisp
+++ b/src/boot/strap/ast.clisp
@@ -51,86 +51,88 @@
(DEFUN |%DefaultValue| #1=(|bfVar#24| |bfVar#25|)
(CONS '|%DefaultValue| (LIST . #1#)))
-(DEFUN |%Bracket| #1=(|bfVar#26|) (CONS '|%Bracket| (LIST . #1#)))
+(DEFUN |%Key| #1=(|bfVar#26| |bfVar#27|) (CONS '|%Key| (LIST . #1#)))
-(DEFUN |%UnboundedSegment| #1=(|bfVar#27|)
+(DEFUN |%Bracket| #1=(|bfVar#28|) (CONS '|%Bracket| (LIST . #1#)))
+
+(DEFUN |%UnboundedSegment| #1=(|bfVar#29|)
(CONS '|%UnboundedSegment| (LIST . #1#)))
-(DEFUN |%BoundedSgement| #1=(|bfVar#28| |bfVar#29|)
+(DEFUN |%BoundedSgement| #1=(|bfVar#30| |bfVar#31|)
(CONS '|%BoundedSgement| (LIST . #1#)))
-(DEFUN |%Tuple| #1=(|bfVar#30|) (CONS '|%Tuple| (LIST . #1#)))
+(DEFUN |%Tuple| #1=(|bfVar#32|) (CONS '|%Tuple| (LIST . #1#)))
-(DEFUN |%ColonAppend| #1=(|bfVar#31| |bfVar#32|)
+(DEFUN |%ColonAppend| #1=(|bfVar#33| |bfVar#34|)
(CONS '|%ColonAppend| (LIST . #1#)))
-(DEFUN |%Pretend| #1=(|bfVar#33| |bfVar#34|) (CONS '|%Pretend| (LIST . #1#)))
+(DEFUN |%Pretend| #1=(|bfVar#35| |bfVar#36|) (CONS '|%Pretend| (LIST . #1#)))
-(DEFUN |%Is| #1=(|bfVar#35| |bfVar#36|) (CONS '|%Is| (LIST . #1#)))
+(DEFUN |%Is| #1=(|bfVar#37| |bfVar#38|) (CONS '|%Is| (LIST . #1#)))
-(DEFUN |%Isnt| #1=(|bfVar#37| |bfVar#38|) (CONS '|%Isnt| (LIST . #1#)))
+(DEFUN |%Isnt| #1=(|bfVar#39| |bfVar#40|) (CONS '|%Isnt| (LIST . #1#)))
-(DEFUN |%Reduce| #1=(|bfVar#39| |bfVar#40|) (CONS '|%Reduce| (LIST . #1#)))
+(DEFUN |%Reduce| #1=(|bfVar#41| |bfVar#42|) (CONS '|%Reduce| (LIST . #1#)))
-(DEFUN |%PrefixExpr| #1=(|bfVar#41| |bfVar#42|)
+(DEFUN |%PrefixExpr| #1=(|bfVar#43| |bfVar#44|)
(CONS '|%PrefixExpr| (LIST . #1#)))
-(DEFUN |%Call| #1=(|bfVar#43| |bfVar#44|) (CONS '|%Call| (LIST . #1#)))
+(DEFUN |%Call| #1=(|bfVar#45| |bfVar#46|) (CONS '|%Call| (LIST . #1#)))
-(DEFUN |%InfixExpr| #1=(|bfVar#45| |bfVar#46| |bfVar#47|)
+(DEFUN |%InfixExpr| #1=(|bfVar#47| |bfVar#48| |bfVar#49|)
(CONS '|%InfixExpr| (LIST . #1#)))
-(DEFUN |%ConstantDefinition| #1=(|bfVar#48| |bfVar#49|)
+(DEFUN |%ConstantDefinition| #1=(|bfVar#50| |bfVar#51|)
(CONS '|%ConstantDefinition| (LIST . #1#)))
-(DEFUN |%Definition| #1=(|bfVar#50| |bfVar#51| |bfVar#52|)
+(DEFUN |%Definition| #1=(|bfVar#52| |bfVar#53| |bfVar#54|)
(CONS '|%Definition| (LIST . #1#)))
-(DEFUN |%Macro| #1=(|bfVar#53| |bfVar#54| |bfVar#55|)
+(DEFUN |%Macro| #1=(|bfVar#55| |bfVar#56| |bfVar#57|)
(CONS '|%Macro| (LIST . #1#)))
-(DEFUN |%Lambda| #1=(|bfVar#56| |bfVar#57|) (CONS '|%Lambda| (LIST . #1#)))
+(DEFUN |%Lambda| #1=(|bfVar#58| |bfVar#59|) (CONS '|%Lambda| (LIST . #1#)))
-(DEFUN |%SuchThat| #1=(|bfVar#58|) (CONS '|%SuchThat| (LIST . #1#)))
+(DEFUN |%SuchThat| #1=(|bfVar#60|) (CONS '|%SuchThat| (LIST . #1#)))
-(DEFUN |%Assignment| #1=(|bfVar#59| |bfVar#60|)
+(DEFUN |%Assignment| #1=(|bfVar#61| |bfVar#62|)
(CONS '|%Assignment| (LIST . #1#)))
-(DEFUN |%While| #1=(|bfVar#61|) (CONS '|%While| (LIST . #1#)))
+(DEFUN |%While| #1=(|bfVar#63|) (CONS '|%While| (LIST . #1#)))
-(DEFUN |%Until| #1=(|bfVar#62|) (CONS '|%Until| (LIST . #1#)))
+(DEFUN |%Until| #1=(|bfVar#64|) (CONS '|%Until| (LIST . #1#)))
-(DEFUN |%For| #1=(|bfVar#63| |bfVar#64| |bfVar#65|) (CONS '|%For| (LIST . #1#)))
+(DEFUN |%For| #1=(|bfVar#65| |bfVar#66| |bfVar#67|) (CONS '|%For| (LIST . #1#)))
-(DEFUN |%Implies| #1=(|bfVar#66| |bfVar#67|) (CONS '|%Implies| (LIST . #1#)))
+(DEFUN |%Implies| #1=(|bfVar#68| |bfVar#69|) (CONS '|%Implies| (LIST . #1#)))
-(DEFUN |%Iterators| #1=(|bfVar#68|) (CONS '|%Iterators| (LIST . #1#)))
+(DEFUN |%Iterators| #1=(|bfVar#70|) (CONS '|%Iterators| (LIST . #1#)))
-(DEFUN |%Cross| #1=(|bfVar#69|) (CONS '|%Cross| (LIST . #1#)))
+(DEFUN |%Cross| #1=(|bfVar#71|) (CONS '|%Cross| (LIST . #1#)))
-(DEFUN |%Repeat| #1=(|bfVar#70| |bfVar#71|) (CONS '|%Repeat| (LIST . #1#)))
+(DEFUN |%Repeat| #1=(|bfVar#72| |bfVar#73|) (CONS '|%Repeat| (LIST . #1#)))
-(DEFUN |%Pile| #1=(|bfVar#72|) (CONS '|%Pile| (LIST . #1#)))
+(DEFUN |%Pile| #1=(|bfVar#74|) (CONS '|%Pile| (LIST . #1#)))
-(DEFUN |%Append| #1=(|bfVar#73|) (CONS '|%Append| (LIST . #1#)))
+(DEFUN |%Append| #1=(|bfVar#75|) (CONS '|%Append| (LIST . #1#)))
-(DEFUN |%Case| #1=(|bfVar#74| |bfVar#75|) (CONS '|%Case| (LIST . #1#)))
+(DEFUN |%Case| #1=(|bfVar#76| |bfVar#77|) (CONS '|%Case| (LIST . #1#)))
-(DEFUN |%Return| #1=(|bfVar#76|) (CONS '|%Return| (LIST . #1#)))
+(DEFUN |%Return| #1=(|bfVar#78|) (CONS '|%Return| (LIST . #1#)))
-(DEFUN |%Leave| #1=(|bfVar#77|) (CONS '|%Leave| (LIST . #1#)))
+(DEFUN |%Leave| #1=(|bfVar#79|) (CONS '|%Leave| (LIST . #1#)))
-(DEFUN |%Throw| #1=(|bfVar#78|) (CONS '|%Throw| (LIST . #1#)))
+(DEFUN |%Throw| #1=(|bfVar#80|) (CONS '|%Throw| (LIST . #1#)))
-(DEFUN |%Catch| #1=(|bfVar#79| |bfVar#80|) (CONS '|%Catch| (LIST . #1#)))
+(DEFUN |%Catch| #1=(|bfVar#81| |bfVar#82|) (CONS '|%Catch| (LIST . #1#)))
-(DEFUN |%Finally| #1=(|bfVar#81|) (CONS '|%Finally| (LIST . #1#)))
+(DEFUN |%Finally| #1=(|bfVar#83|) (CONS '|%Finally| (LIST . #1#)))
-(DEFUN |%Try| #1=(|bfVar#82| |bfVar#83|) (CONS '|%Try| (LIST . #1#)))
+(DEFUN |%Try| #1=(|bfVar#84| |bfVar#85|) (CONS '|%Try| (LIST . #1#)))
-(DEFUN |%Where| #1=(|bfVar#84| |bfVar#85|) (CONS '|%Where| (LIST . #1#)))
+(DEFUN |%Where| #1=(|bfVar#86| |bfVar#87|) (CONS '|%Where| (LIST . #1#)))
-(DEFUN |%Structure| #1=(|bfVar#86| |bfVar#87|)
+(DEFUN |%Structure| #1=(|bfVar#88| |bfVar#89|)
(CONS '|%Structure| (LIST . #1#)))
(DEFPARAMETER |$inDefIS| NIL)
@@ -1151,8 +1153,38 @@
(COND ((SYMBOLP |prop|) (LIST 'GET |expr| (|quote| |prop|)))
(T (|bpSpecificErrorHere| "expected identifier as property name"))))
+(DEFUN |bfKeyArg| (|k| |x|) (LIST '|%Key| |k| |x|))
+
+(DEFUN |bfExpandKeys| (|l|)
+ (PROG (|x| |ISTMP#2| |k| |ISTMP#1| |a| |args|)
+ (RETURN
+ (PROGN
+ (SETQ |args| NIL)
+ (LOOP
+ (COND
+ ((NOT
+ (AND (CONSP |l|)
+ (PROGN (SETQ |a| (CAR |l|)) (SETQ |l| (CDR |l|)) T)))
+ (RETURN NIL))
+ ((AND (CONSP |a|) (EQ (CAR |a|) '|%Key|)
+ (PROGN
+ (SETQ |ISTMP#1| (CDR |a|))
+ (AND (CONSP |ISTMP#1|)
+ (PROGN
+ (SETQ |k| (CAR |ISTMP#1|))
+ (SETQ |ISTMP#2| (CDR |ISTMP#1|))
+ (AND (CONSP |ISTMP#2|) (NULL (CDR |ISTMP#2|))
+ (PROGN (SETQ |x| (CAR |ISTMP#2|)) T))))))
+ (SETQ |args|
+ (CONS |x|
+ (CONS
+ (INTERN (STRING-UPCASE (SYMBOL-NAME |k|)) "KEYWORD")
+ |args|))))
+ (T (SETQ |args| (CONS |a| |args|)))))
+ (|reverse!| |args|)))))
+
(DEFUN |bfApplication| (|bfop| |bfarg|)
- (COND ((|bfTupleP| |bfarg|) (CONS |bfop| (CDR |bfarg|)))
+ (COND ((|bfTupleP| |bfarg|) (CONS |bfop| (|bfExpandKeys| (CDR |bfarg|))))
(T (LIST |bfop| |bfarg|))))
(DEFUN |bfReName| (|x|)
diff --git a/src/boot/strap/parser.clisp b/src/boot/strap/parser.clisp
index f6799dbf..f8417b34 100644
--- a/src/boot/strap/parser.clisp
+++ b/src/boot/strap/parser.clisp
@@ -863,6 +863,7 @@
(COND
((|bpEqPeek| 'BEC) (|bpRestore| |a|) (OR (|bpAssignment|) (|bpTrap|)))
((|bpEqPeek| 'GIVES) (|bpRestore| |a|) (OR (|bpLambda|) (|bpTrap|)))
+ ((|bpEqPeek| 'LARROW) (|bpRestore| |a|) (OR (|bpKeyArg|) (|bpTrap|)))
(T T)))
(T (|bpRestore| |a|) NIL))))))
@@ -874,6 +875,10 @@
(AND (|bpVariable|) (|bpEqKey| 'GIVES) (OR (|bpAssign|) (|bpTrap|))
(|bpPush| (|bfLambda| (|bpPop2|) (|bpPop1|)))))
+(DEFUN |bpKeyArg| ()
+ (AND (|bpName|) (|bpEqKey| 'LARROW) (|bpLogical|)
+ (|bpPush| (|bfKeyArg| (|bpPop2|) (|bpPop1|)))))
+
(DEFUN |bpExit| ()
(AND (|bpAssign|)
(OR
diff --git a/src/boot/strap/tokens.clisp b/src/boot/strap/tokens.clisp
index e59680a6..c259bda3 100644
--- a/src/boot/strap/tokens.clisp
+++ b/src/boot/strap/tokens.clisp
@@ -43,10 +43,10 @@
(LIST "<" 'LT) (LIST ">" 'GT) (LIST "<=" 'LE) (LIST ">=" 'GE)
(LIST "=" 'SHOEEQ) (LIST "~=" 'SHOENE) (LIST ".." 'SEG)
(LIST "#" 'LENGTH) (LIST "=>" 'EXIT) (LIST "->" 'ARROW)
- (LIST ":=" 'BEC) (LIST "+->" 'GIVES) (LIST "==" 'DEF)
- (LIST "<=>" 'TDEF) (LIST "(" 'OPAREN) (LIST ")" 'CPAREN)
- (LIST "[" 'OBRACK) (LIST "]" 'CBRACK) (LIST "'" 'QUOTE)
- (LIST "|" 'BAR)))
+ (LIST "<-" 'LARROW) (LIST ":=" 'BEC) (LIST "+->" 'GIVES)
+ (LIST "==" 'DEF) (LIST "<=>" 'TDEF) (LIST "(" 'OPAREN)
+ (LIST ")" 'CPAREN) (LIST "[" 'OBRACK) (LIST "]" 'CBRACK)
+ (LIST "'" 'QUOTE) (LIST "|" 'BAR)))
(DEFUN |shoeKeyTableCons| ()
(PROG (|KeyTable|)
diff --git a/src/boot/tokens.boot b/src/boot/tokens.boot
index 2adea400..e8909318 100644
--- a/src/boot/tokens.boot
+++ b/src/boot/tokens.boot
@@ -110,6 +110,7 @@ shoeKeyWords == [ _
['"#", "LENGTH"], _
['"=>","EXIT" ], _
['"->", "ARROW"],_
+ ['"<-", "LARROW"], _
['":=", "BEC"], _
['"+->", "GIVES"], _
['"==", "DEF"], _
diff --git a/src/interp/br-op1.boot b/src/interp/br-op1.boot
index c31af10f..db446fb5 100644
--- a/src/interp/br-op1.boot
+++ b/src/interp/br-op1.boot
@@ -405,8 +405,8 @@ dbGatherDataImplementation(htPage,opAlist) ==
key is 'nowhere => nowheres := [x,:nowheres]
key is 'constant =>constants := [x,:constants]
others := [x,:others] --add chain domains go here
- fn [nowheres,constants,domexports,SORTBY('CDDR,reverse! others),SORTBY('CDDR,
- reverse! defexports),SORTBY('CDDR,reverse! unexports)] where
+ fn [nowheres,constants,domexports,sortBy('CDDR,others),
+ sortBy('CDDR,defexports),sortBy('CDDR,unexports)] where
fn l ==
alist := nil
for u in l repeat
diff --git a/src/interp/c-util.boot b/src/interp/c-util.boot
index e09772c6..a032f0a8 100644
--- a/src/interp/c-util.boot
+++ b/src/interp/c-util.boot
@@ -1825,9 +1825,9 @@ compileQuietly fn ==
++ If `x' is a formal map variable, returns its position.
++ Otherwise return nil.
-isFormal: %Symbol -> %Maybe %Short
-isFormal x ==
- POSITION(x,$FormalMapVariableList,KEYWORD::TEST, function EQ)
+formal?: %Symbol -> %Maybe %Short
+formal? x ==
+ or/[i for i in 0.. for y in $FormalMapVariableList | symbolEq?(x,y)]
++ Expand the form at position `slot' in the domain template `shell'
++ with argument list `args'.
@@ -1837,7 +1837,7 @@ expandFormTemplate(shell,args,slot) ==
slot = 2 => "$$"
expandFormTemplate(shell,args,vectorRef(shell,slot))
slot isnt [.,:.] => slot
- slot is ["local",parm] and (n := isFormal parm) =>
+ slot is ["local",parm] and (n := formal? parm) =>
args.n -- FIXME: we should probably expand with dual signature
slot is ['%eval,val] => val
slot is ['QUOTE,val] =>
@@ -1852,9 +1852,9 @@ equalFormTemplate(shell,args,slot,form) ==
slot = 0 => form = "$"
slot = 2 => form = "$$"
equalFormTemplate(shell,args,vectorRef(shell,slot),form)
- slot is ["local",parm] and (n := isFormal parm) =>
+ slot is ["local",parm] and (n := formal? parm) =>
equalFormTemplate(shell,args,args.n,form)
- slot is ["NTREVAL",val] => form = val
+ slot is ['%eval,val] => form = val
slot is ['QUOTE,val] =>
string? val or symbol? val or integer? val => val = form
slot = form
diff --git a/src/interp/cattable.boot b/src/interp/cattable.boot
index 3ed51a32..34bd928e 100644
--- a/src/interp/cattable.boot
+++ b/src/interp/cattable.boot
@@ -272,7 +272,7 @@ formalSubstitute(form:=[.,:argl],u) ==
applySubst(pairList($FormalMapVariableList,argl),u)
isFormalArgumentList argl ==
- and/[x=fa for x in argl for fa in $FormalMapVariableList]
+ and/[symbolEq?(x,fa) for x in argl for fa in $FormalMapVariableList]
mkCategoryExtensionAlist cform ==
not cons? cform => nil
diff --git a/src/interp/clam.boot b/src/interp/clam.boot
index a0c57a41..f1f88374 100644
--- a/src/interp/clam.boot
+++ b/src/interp/clam.boot
@@ -364,7 +364,7 @@ clearCategoryCache catName ==
symbolValue(mkCacheName catName) := nil
displayHashtable x ==
- l:= reverse! SORTBY('CAR,[[opOf val,key] for [key,:val] in entries x])
+ l := sortBy(function first,[[opOf val,key] for [key,:val] in entries x])
for [a,b] in l repeat
sayBrightlyNT ['"%b",a,'"%d"]
pp b
@@ -387,7 +387,7 @@ reportCircularCacheStats(fn,n) ==
TERPRI()
displayCacheFrequency al ==
- al := reverse! SORTBY('CAR,al)
+ al := sortBy(function first,al)
sayBrightlyNT " #hits/#occurrences: "
for [a,:b] in al repeat sayBrightlyNT [a,"/",b," "]
TERPRI()
@@ -572,7 +572,7 @@ reportInstantiations() ==
sayBrightly ['"# instantiated/# dropped/domain name",
"%l",'"------------------------------------"]
nTotal:= mTotal:= rTotal := nForms:= 0
- for [n,m,form] in reverse! SORTBY('CADDR,conList) repeat
+ for [n,m,form] in sortBy(function third,conList) repeat
nTotal:= nTotal+n; mTotal:= mTotal+m
if n > 1 then rTotal:= rTotal + n-1
nForms:= nForms + 1
@@ -669,7 +669,7 @@ globalHashtableStats(x,sortFn) ==
argList1:= [constructor2ConstructorForm x for x in argList]
reportList:= [[n,key,argList1],:reportList]
sayBrightly ["%b"," USE NAME ARGS","%d"]
- for [n,fn,args] in reverse! SORTBY(sortFn,reportList) repeat
+ for [n,fn,args] in sortBy(sortFn,reportList) repeat
sayBrightlyNT [:rightJustifyString(n,6)," ",fn,": "]
pp args
diff --git a/src/interp/define.boot b/src/interp/define.boot
index 8edc4da2..d2fa9601 100644
--- a/src/interp/define.boot
+++ b/src/interp/define.boot
@@ -465,7 +465,7 @@ NRTmakeCategoryAlist(db,e) ==
$catAncestorAlist: local := nil
pcAlist := [:[[x,:"T"] for x in $uncondAlist],:$condAlist]
$levelAlist: local := depthAssocList [CAAR x for x in pcAlist]
- opcAlist := reverse! SORTBY(function NRTcatCompare,pcAlist)
+ opcAlist := sortBy(function NRTcatCompare,pcAlist)
newPairlis := [[5 + i,:b] for [.,:b] in dbFormalSubst db for i in 1..]
slot1 := [[a,:k] for [a,:b] in dbSubstituteAllQuantified(db,opcAlist)
| (k := predicateBitIndex(b,e)) ~= -1]
diff --git a/src/interp/i-coerfn.boot b/src/interp/i-coerfn.boot
index d1825ac3..bf42e2cf 100644
--- a/src/interp/i-coerfn.boot
+++ b/src/interp/i-coerfn.boot
@@ -287,7 +287,7 @@ Dmp2Up(u, source is [dmp,vl,S],target is [up,var,T]) ==
-- only one variable in DMP case
null vl' =>
- u' := reverse! SORTBY('CAR,[[e.0,:c] for [e,:c] in u])
+ u' := sortBy(function first,[[e.0,:c] for [e,:c] in u])
(u' := coerceInt(objNewWrap(u',[up,var,S]),target)) or
coercionFailure()
objValUnwrap u'
@@ -308,7 +308,7 @@ Dmp2Up(u, source is [dmp,vl,S],target is [up,var,T]) ==
p.rest := c'
zero = objValUnwrap(y) => 'iterate
x := [[exp,:objValUnwrap(y)],:x]
- y => reverse! SORTBY('CAR,x)
+ y => sortBy(function first,x)
coercionFailure()
removeVectorElt(v,pos) ==
diff --git a/src/interp/i-output.boot b/src/interp/i-output.boot
index 421e9386..ccd535b7 100644
--- a/src/interp/i-output.boot
+++ b/src/interp/i-output.boot
@@ -1773,7 +1773,7 @@ charyTop(u,start,linelength) ==
-->
$testOutputLineFlag =>
$testOutputLineList :=
- [:ASSOCRIGHT SORTBY('CAR,d),:$testOutputLineList]
+ [:ASSOCRIGHT reverse! sortBy(function first,d),:$testOutputLineList]
until n < m repeat
scylla(n,d)
n := n - 1
diff --git a/src/interp/i-syscmd.boot b/src/interp/i-syscmd.boot
index d9cd3197..e15c18fb 100644
--- a/src/interp/i-syscmd.boot
+++ b/src/interp/i-syscmd.boot
@@ -2703,7 +2703,7 @@ workfilesSpad2Cmd args ==
centerAndHighlight(" User-specified work files ",$LINELENGTH,specialChar 'hbar)
SAY " "
null $sourceFiles => SAY '" no files specified"
- SETQ($sourceFiles,SORTBY('pathnameType,$sourceFiles))
+ SETQ($sourceFiles,sortBy(function pathnameType,$sourceFiles))
for fl in $sourceFiles repeat sayBrightly [" " ,namestring fl]
--% )zsystemdevelopment
diff --git a/src/interp/showimp.boot b/src/interp/showimp.boot
index 000154f4..deb1f816 100644
--- a/src/interp/showimp.boot
+++ b/src/interp/showimp.boot
@@ -70,7 +70,7 @@ showImp(dom,:options) ==
missingOnlyFlag => 'done
--first display those exported by the domain, then add chain guys
- u := [:domexports,:constants,:SORTBY('CDDR,others)]
+ u := [:domexports,:constants,:reverse! sortBy(function CDDR,others)]
while u repeat
[.,.,:key] := first u
sayBrightly
@@ -78,14 +78,14 @@ showImp(dom,:options) ==
["Constants implemented by",:bright form2String key,'":"]
["Functions implemented by",:bright form2String key,'":"]
u := showDomainsOp1(u,key)
- u := SORTBY('CDDR,defexports)
+ u := reverse! sortBy(function CDDR,defexports)
while u repeat
[.,.,:key] := first u
defop := makeSymbol(subString((s := PNAME first key),0,maxIndex s))
domainForm := [defop,:CDDR key]
sayBrightly ["Default functions from",:bright form2String domainForm,'":"]
u := showDomainsOp1(u,key)
- u := SORTBY('CDDR,unexports)
+ u := reverse! sortBy(function CDDR,unexports)
while u repeat
[.,.,:key] := first u
sayBrightly ["Not exported: "]
diff --git a/src/interp/sys-utility.boot b/src/interp/sys-utility.boot
index 96bd829b..31168d54 100644
--- a/src/interp/sys-utility.boot
+++ b/src/interp/sys-utility.boot
@@ -388,6 +388,9 @@ remove!(l,x) ==
return l
p := rest p
+sortBy(k,l) ==
+ SORT(copyList l,function GGREATERP,key <- k)
+
++ Return the list of objects that follow x in l, including x itself.
++ Otherwise return nil.
upwardCut(x,l) ==
diff --git a/src/interp/vmlisp.lisp b/src/interp/vmlisp.lisp
index e571a161..47ccdec1 100644
--- a/src/interp/vmlisp.lisp
+++ b/src/interp/vmlisp.lisp
@@ -676,16 +676,6 @@
(SETQ Y (CDR Y))
(GO A)))))
-; 14.6 Miscellaneous
-
-(defun QSORT (l)
- (declare (special sortgreaterp))
- (|reverse!| (sort (copy-seq l) SORTGREATERP)))
-
-(defun SORTBY (keyfn l)
- (declare (special sortgreaterp))
- (|reverse!| (sort (copy-seq l) SORTGREATERP :key keyfn)))
-
; 16.0 Operations on Vectors
; 16.1 Creation
generated by cgit v1.2.3 (git 2.39.1) at 2024-08-12 01:36:10 +0000