core: removing unnecessary method stack effects.
							parent
							
								
									f3ae869536
								
							
						
					
					
						commit
						f2deb82829
					
				|  | @ -120,7 +120,7 @@ PRIVATE> | |||
| : of ( assoc key -- value/f ) | ||||
|     swap at ; inline | ||||
| 
 | ||||
| M: assoc assoc-clone-like ( assoc exemplar -- newassoc ) | ||||
| M: assoc assoc-clone-like | ||||
|     [ dup assoc-size ] dip new-assoc | ||||
|     [ [ set-at ] with-assoc assoc-each ] keep ; inline | ||||
| 
 | ||||
|  | @ -299,7 +299,7 @@ M: enumerated set-at seq>> set-nth ; inline | |||
| 
 | ||||
| M: enumerated delete-at seq>> remove-nth! drop ; inline | ||||
| 
 | ||||
| M: enumerated >alist ( enumerated -- alist ) ; inline | ||||
| M: enumerated >alist ; inline | ||||
| 
 | ||||
| M: enumerated keys seq>> length <iota> >array ; inline | ||||
| 
 | ||||
|  |  | |||
|  | @ -253,7 +253,7 @@ PRIVATE> | |||
| M: class metaclass-changed | ||||
|     swap class? [ drop ] [ forget-class ] if ; | ||||
| 
 | ||||
| M: class forget* ( class -- ) | ||||
| M: class forget* | ||||
|     [ call-next-method ] [ forget-class ] bi ; | ||||
| 
 | ||||
| ERROR: not-an-instance obj class ; | ||||
|  |  | |||
|  | @ -93,7 +93,7 @@ PRIVATE> | |||
| 
 | ||||
| GENERIC: slots>tuple ( seq class -- tuple ) | ||||
| 
 | ||||
| M: tuple-class slots>tuple ( seq class -- tuple ) | ||||
| M: tuple-class slots>tuple | ||||
|     check-slots pad-slots | ||||
|     tuple-layout <tuple> [ | ||||
|         [ tuple-size <iota> ] | ||||
|  |  | |||
|  | @ -49,13 +49,13 @@ HOOK: update-call-sites compiler-impl ( class generic -- words ) | |||
| : changed-call-sites ( class generic -- ) | ||||
|     update-call-sites [ changed-definition ] each ; | ||||
| 
 | ||||
| M: generic update-generic ( class generic -- ) | ||||
| M: generic update-generic | ||||
|     [ changed-call-sites ] | ||||
|     [ remake-generic drop ] | ||||
|     [ changed-conditionally drop ] | ||||
|     2tri ; | ||||
| 
 | ||||
| M: sequence update-methods ( class seq -- ) | ||||
| M: sequence update-methods | ||||
|     implementors [ update-generic ] with each ; | ||||
| 
 | ||||
| HOOK: recompile compiler-impl ( words -- alist ) | ||||
|  |  | |||
|  | @ -71,7 +71,7 @@ M: pair effect>string | |||
| 
 | ||||
| PRIVATE> | ||||
| 
 | ||||
| M: effect effect>string ( effect -- string ) | ||||
| M: effect effect>string | ||||
|     [ | ||||
|         "( " % | ||||
|         dup in-var>> var-picture% | ||||
|  |  | |||
|  | @ -39,7 +39,7 @@ SYMBOL: combination | |||
| 
 | ||||
| HOOK: picker combination ( -- quot ) | ||||
| 
 | ||||
| M: single-combination next-method-quot* ( class generic combination -- quot ) | ||||
| M: single-combination next-method-quot* | ||||
|     [ | ||||
|         2dup next-method dup [ | ||||
|             [ | ||||
|  |  | |||
|  | @ -32,12 +32,12 @@ PRIVATE> | |||
| 
 | ||||
| GENERIC: contract ( len seq -- ) | ||||
| 
 | ||||
| M: growable contract ( len seq -- ) | ||||
| M: growable contract | ||||
|     [ length ] keep | ||||
|     [ [ 0 ] 2dip set-nth-unsafe ] curry | ||||
|     (each-integer) ; inline | ||||
| 
 | ||||
| M: growable set-length ( n seq -- ) | ||||
| M: growable set-length | ||||
|     bounds-check-head | ||||
|     2dup length < [ | ||||
|         2dup contract | ||||
|  | @ -62,13 +62,13 @@ M: growable set-nth ensure set-nth-unsafe ; inline | |||
| 
 | ||||
| M: growable clone (clone) [ clone ] change-underlying ; inline | ||||
| 
 | ||||
| M: growable lengthen ( n seq -- ) | ||||
| M: growable lengthen | ||||
|     2dup length > [ | ||||
|         2dup capacity > [ over new-size over expand ] when | ||||
|         2dup length<< | ||||
|     ] when 2drop ; inline | ||||
| 
 | ||||
| M: growable shorten ( n seq -- ) | ||||
| M: growable shorten | ||||
|     bounds-check-head | ||||
|     2dup length < [ | ||||
|         2dup contract | ||||
|  |  | |||
|  | @ -109,7 +109,7 @@ M: decoder stream-element-type | |||
|         over cr- dup CHAR: \n eq? [ drop (read1) ] [ nip ] if | ||||
|     ] [ nip ] if ; inline | ||||
| 
 | ||||
| M: decoder stream-read1 ( decoder -- ch ) | ||||
| M: decoder stream-read1 | ||||
|     dup (read1) fix-cr ; inline | ||||
| 
 | ||||
| : (read-first) ( n buf decoder -- buf stream encoding n c ) | ||||
|  |  | |||
|  | @ -87,7 +87,7 @@ M: utf16le decode-char | |||
|         [ [ encode-second ] dip stream-write2 ] 2bi | ||||
|     ] [ [ h>b/b swap ] dip stream-write2 ] if ; inline | ||||
| 
 | ||||
| M: utf16be encode-char ( char stream encoding -- ) | ||||
| M: utf16be encode-char | ||||
|     drop char>utf16be ; | ||||
| 
 | ||||
| : char>utf16le ( char stream -- ) | ||||
|  | @ -97,7 +97,7 @@ M: utf16be encode-char ( char stream encoding -- ) | |||
|         [ [ encode-second swap ] dip stream-write2 ] 2bi | ||||
|     ] [ [ h>b/b ] dip stream-write2 ] if ; inline | ||||
| 
 | ||||
| M: utf16le encode-char ( char stream encoding -- ) | ||||
| M: utf16le encode-char | ||||
|     drop char>utf16le ; | ||||
| 
 | ||||
| : ascii-char>utf16-byte-array ( off n byte-array string -- ) | ||||
|  | @ -155,10 +155,10 @@ CONSTANT: bom-be B{ 0xfe 0xff } | |||
|         bom-be sequence= [ utf16be ] [ missing-bom ] if | ||||
|     ] if ; | ||||
| 
 | ||||
| M: utf16 <decoder> ( stream utf16 -- decoder ) | ||||
| M: utf16 <decoder> | ||||
|     drop 2 over stream-read bom>le/be <decoder> ; | ||||
| 
 | ||||
| M: utf16 <encoder> ( stream utf16 -- encoder ) | ||||
| M: utf16 <encoder> | ||||
|     drop bom-le over stream-write utf16le <encoder> ; | ||||
| 
 | ||||
| PRIVATE> | ||||
|  |  | |||
|  | @ -80,7 +80,7 @@ HOOK: cd io-backend ( path -- ) | |||
| 
 | ||||
| HOOK: cwd io-backend ( -- path ) | ||||
| 
 | ||||
| M: object cwd ( -- path ) "." ; | ||||
| M: object cwd "." ; | ||||
| 
 | ||||
| PRIVATE> | ||||
| 
 | ||||
|  |  | |||
|  | @ -21,7 +21,7 @@ SYMBOL: current-directory | |||
| 
 | ||||
| HOOK: root-directory? io-backend ( path -- ? ) | ||||
| 
 | ||||
| M: object root-directory? ( path -- ? ) | ||||
| M: object root-directory? | ||||
|     [ f ] [ [ path-separator? ] all? ] if-empty ; | ||||
| 
 | ||||
| ERROR: no-parent-directory path ; | ||||
|  | @ -163,7 +163,7 @@ M: string absolute-path | |||
|         ] if ] if | ||||
|     ] if ; | ||||
| 
 | ||||
| M: object normalize-path ( path -- path' ) | ||||
| M: object normalize-path | ||||
|     absolute-path ; | ||||
| 
 | ||||
| : root-path* ( path -- path' ) | ||||
|  |  | |||
|  | @ -223,7 +223,7 @@ M: bignum (log2) bignum-log2 ; inline | |||
| : bignum/f ( m n -- f ) | ||||
|     [ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ; inline | ||||
| 
 | ||||
| M: bignum /f ( m n -- f ) { bignum bignum } declare bignum/f ; | ||||
| M: bignum /f { bignum bignum } declare bignum/f ; | ||||
| 
 | ||||
| CONSTANT: bignum/f-threshold 0x20,0000,0000,0000 | ||||
| 
 | ||||
|  |  | |||
|  | @ -37,15 +37,15 @@ GENERIC: after? ( obj1 obj2 -- ? ) | |||
| GENERIC: before=? ( obj1 obj2 -- ? ) | ||||
| GENERIC: after=? ( obj1 obj2 -- ? ) | ||||
| 
 | ||||
| M: object before? ( obj1 obj2 -- ? ) <=> +lt+ eq? ; inline | ||||
| M: object after? ( obj1 obj2 -- ? ) <=> +gt+ eq? ; inline | ||||
| M: object before=? ( obj1 obj2 -- ? ) <=> +gt+ eq? not ; inline | ||||
| M: object after=? ( obj1 obj2 -- ? ) <=> +lt+ eq? not ; inline | ||||
| M: object before? <=> +lt+ eq? ; inline | ||||
| M: object after? <=> +gt+ eq? ; inline | ||||
| M: object before=? <=> +gt+ eq? not ; inline | ||||
| M: object after=? <=> +lt+ eq? not ; inline | ||||
| 
 | ||||
| M: real before? ( obj1 obj2 -- ? ) < ; inline | ||||
| M: real after? ( obj1 obj2 -- ? ) > ; inline | ||||
| M: real before=? ( obj1 obj2 -- ? ) <= ; inline | ||||
| M: real after=? ( obj1 obj2 -- ? ) >= ; inline | ||||
| M: real before? < ; inline | ||||
| M: real after? > ; inline | ||||
| M: real before=? <= ; inline | ||||
| M: real after=? >= ; inline | ||||
| 
 | ||||
| GENERIC: min ( obj1 obj2 -- obj ) | ||||
| GENERIC: max ( obj1 obj2 -- obj ) | ||||
|  |  | |||
|  | @ -53,7 +53,7 @@ ERROR: bounds-error index seq ; | |||
| 
 | ||||
| GENERIC#: bounds-check? 1 ( n seq -- ? ) | ||||
| 
 | ||||
| M: integer bounds-check? ( n seq -- ? ) | ||||
| M: integer bounds-check? | ||||
|     dupd length < [ 0 >= ] [ drop f ] if ; inline | ||||
| 
 | ||||
| : bounds-check ( n seq -- n seq ) | ||||
|  |  | |||
|  | @ -72,7 +72,7 @@ ERROR: bad-slot-value value class ; | |||
| 
 | ||||
| GENERIC: instance-check-quot ( obj -- quot ) | ||||
| 
 | ||||
| M: class instance-check-quot ( class -- quot ) | ||||
| M: class instance-check-quot | ||||
|     { | ||||
|         { [ dup object bootstrap-word eq? ] [ drop [ ] ] } | ||||
|         { [ dup "coercer" word-prop ] [ "coercer" word-prop ] } | ||||
|  |  | |||
|  | @ -36,7 +36,7 @@ ERROR: not-found-in-roots path ; | |||
| : find-root-for ( path -- path/f ) | ||||
|     vocab-roots get [ prepend-path exists? ] with find nip ; | ||||
| 
 | ||||
| M: string vocab-path ( string -- path/f ) | ||||
| M: string vocab-path | ||||
|     dup find-root-for [ prepend-path ] [ not-found-in-roots ] if* ; | ||||
| 
 | ||||
| PRIVATE> | ||||
|  |  | |||
		Loading…
	
		Reference in New Issue