steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

more compiler work, a few java factor fixes

cvs
Slava Pestov 2004-09-07 02:39:12 +00:00
parent ea3ad6f14f
commit 77bfc275a2
33 changed files with 466 additions and 170 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
TODO.FACTOR.txt
View File

@ -4,11 +4,16 @@
- plugin should not exit jEdit on fatal errors
- wordpreview: don't show for string literals and comments
- alist -vs- assoc terminology
- NPE in activate()/deactivate()
- write-icon kind of messy; " " should be output by the listener
- f usages. --> don't print all words
- file responder: don't show full path in title
- clean up listener's action popups
- jedit ==> jedit-word, jedit takes a file name
- introduce ifte* and ?str-head/?str-tail where appropriate
- namespace clone drops static var bindings
<kc5tja> The binary register ordering, from 0 to 7, is EAX, ECX, EDX, EBX, ESP, EBP, ESI, EDI.
- when running (inf, .factor-rc not loaded
+ bignums:
@ -44,7 +49,6 @@
+ listener/plugin:
- NPE in activate()/deactivate()
- NPE in ErrorHighlight
- some way to not have previous definitions from a source file
clutter the namespace
@ -82,11 +86,6 @@
+ misc:
- write-icon kind of messy; " " should be output by the listener
- f usages. --> don't print all words
- pipe support
- telnetd: init-history
- str-reverse primitive
- some way to run httpd from command line
- don't rehash strings on every startup
- 'cascading' styles

5
factor/FactorLib.java
View File

@ -216,6 +216,11 @@ public class FactorLib
break;
buf.append((char)b);
}
/* EOF? */
if(b == -1 && buf.length() == 0)
return null;
else
return buf.toString();
} //}}}

24
factor/compiler/FlowObject.java
View File

@ -173,11 +173,25 @@ implements Constants, FactorExternalizable, PublicCloneable
}
else
{
mw.visitMethodInsn(INVOKESTATIC,
"factor/FactorJava",
methodName,
"(Ljava/lang/Object;)"
+ FactorJava.javaClassToVMClass(type));
String signature;
if(type.isArray())
{
signature = "(Ljava/lang/Object;)"
+ "[Ljava/lang/Object;";
}
else
{
signature = "(Ljava/lang/Object;)"
+ FactorJava.javaClassToVMClass(type);
}
mw.visitMethodInsn(INVOKESTATIC,"factor/FactorJava",
methodName,signature);
/* if(type.isArray())
{
mw.visitTypeInsn(CHECKCAST,
type.getName()
.replace('.','/'));
} */
}
} //}}}

6
factor/jedit/FactorPlugin.java
View File

@ -309,6 +309,7 @@ public class FactorPlugin extends EditPlugin
Buffer buffer = view.getBuffer();
int lastUseOffset = 0;
boolean trailingNewline = false;
for(int i = 0; i < buffer.getLineCount(); i++)
{
@ -325,12 +326,17 @@ public class FactorPlugin extends EditPlugin
lastUseOffset = buffer.getLineEndOffset(i-1) - 1;
}
else
{
trailingNewline = true;
break;
}
}
String decl = "USE: " + vocab;
if(lastUseOffset != 0)
decl = "\n" + decl;
if(trailingNewline)
decl = decl + "\n";
buffer.insert(lastUseOffset,decl);
showStatus(view,"inserted-use",decl);
} //}}}

58
library/compiler/assembler.factor Normal file
View File

@ -0,0 +1,58 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: compiler
USE: math
USE: kernel
USE: stack
: cell 4 ;
: literal-table 1024 cell * ;
: init-assembler ( -- )
compiled-offset literal-table + set-compiled-offset ;
: intern-literal ( obj -- lit# )
address-of
literal-top set-compiled-cell
literal-top dup cell + set-literal-top ;
: compile-byte ( n -- )
compiled-offset set-compiled-byte
compiled-offset 1 + set-compiled-offset ;
: compile-cell ( n -- )
compiled-offset set-compiled-cell
compiled-offset cell + set-compiled-offset ;
: DATASTACK ( -- ptr )
#! A pointer to a pointer to the datastack top.
11 getenv ;
: CALLSTACK ( -- ptr )
#! A pointer to a pointer to the callstack top.
12 getenv ;

106
library/compiler/assembly-x86.factor Normal file
View File

@ -0,0 +1,106 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: compiler
USE: kernel
USE: compiler
USE: math
USE: stack
: EAX 0 ;
: ECX 1 ;
: EDX 2 ;
: EBX 3 ;
: ESP 4 ;
: EBP 5 ;
: ESI 6 ;
: EDI 7 ;
: PUSH ( reg -- )
HEX: 50 + compile-byte ;
: POP ( reg -- )
HEX: 58 + compile-byte ;
: I>R ( imm reg -- )
#! MOV <imm> TO <reg>
HEX: b8 + compile-byte compile-cell ;
: [I]>R ( imm reg -- )
#! MOV INDIRECT <imm> TO <reg>
HEX: a1 + compile-byte compile-cell ;
: I>[R] ( imm reg -- )
#! MOV <imm> TO INDIRECT <reg>
HEX: c7 compile-byte compile-byte compile-cell ;
: [R]>R ( reg reg -- )
#! MOV INDIRECT <reg> TO <reg>.
HEX: 8b compile-byte swap 3 shift bitor compile-byte ;
: R>[R] ( reg reg -- )
#! MOV <reg> TO INDIRECT <reg>.
HEX: 89 compile-byte swap 3 shift bitor compile-byte ;
: I+[I] ( imm addr -- )
#! ADD <imm> TO ADDRESS <addr>
HEX: 81 compile-byte
HEX: 05 compile-byte
compile-cell
compile-cell ;
: LITERAL ( cell -- )
#! Push literal on data stack.
#! Assume that it is ok to clobber EAX without saving.
DATASTACK EAX [I]>R
EAX I>[R]
4 DATASTACK I+[I] ;
: [LITERAL] ( cell -- )
#! Push literal on data stack by following an indirect
#! pointer.
ECX PUSH
( cell -- ) ECX I>R
ECX ECX [R]>R
DATASTACK EAX [I]>R
ECX EAX R>[R]
4 DATASTACK I+[I]
ECX POP ;
: (JMP) ( xt opcode -- )
#! JMP, CALL insn is 5 bytes long
#! addr is relative to *after* insn
compile-byte compiled-offset 4 + - compile-cell ;
: JMP ( -- )
HEX: e9 (JMP) ;
: CALL ( -- )
HEX: e8 (JMP) ;
: RET ( -- )
HEX: c3 compile-byte ;

88
library/compiler/compiler.factor Normal file
View File

@ -0,0 +1,88 @@
! :folding=indent:collapseFolds=1:
! $Id$
!
! Copyright (C) 2004 Slava Pestov.
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are met:
!
! 1. Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! 2. Redistributions in binary form must reproduce the above copyright notice,
! this list of conditions and the following disclaimer in the documentation
! and/or other materials provided with the distribution.
!
! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
IN: compiler
USE: math
USE: stack
USE: lists
USE: combinators
USE: words
USE: namespaces
USE: unparser
USE: errors
USE: strings
USE: logic
USE: kernel
USE: vectors
: compile-word ( word -- )
#! Compile a JMP at the end (tail call optimization)
word-xt "compile-last" get [ JMP ] [ CALL ] ifte ;
: compile-literal ( obj -- )
dup fixnum? [
address-of LITERAL
] [
intern-literal [LITERAL]
] ifte ;
: commit-literals ( -- )
"compile-datastack" get dup [ compile-literal ] vector-each
0 swap set-vector-length ;
: postpone ( obj -- )
"compile-datastack" get vector-push ;
: compile-atom ( obj -- )
[
[ word? ] [ commit-literals compile-word ]
[ drop t ] [ postpone ]
] cond ;
: compile-loop ( quot -- )
dup [
unswons
over not "compile-last" set
compile-atom
compile-loop
] [
commit-literals drop RET
] ifte ;
: compile-quot ( quot -- xt )
[
"compile-last" off
10 <vector> "compile-datastack" set
compiled-offset swap compile-loop
] with-scope ;
: compile ( word -- )
intern dup word-parameter compile-quot swap set-word-xt ;
: call-xt ( xt -- )
#! For testing.
0 f f <word> [ set-word-xt ] keep execute ;

21
library/cross-compiler.factor
View File

@ -42,9 +42,12 @@ USE: vectors
USE: words
IN: compiler
DEFER: compile-byte
DEFER: compile-cell
DEFER: compile-offset
DEFER: set-compiled-byte
DEFER: set-compiled-cell
DEFER: compiled-offset
DEFER: set-compiled-offset
DEFER: literal-top
DEFER: set-literal-top
IN: kernel
DEFER: getenv
@ -54,6 +57,7 @@ DEFER: room
DEFER: os-env
DEFER: type-of
DEFER: size-of
DEFER: address-of
DEFER: dump
IN: strings
@ -150,6 +154,7 @@ IN: cross-compiler
str-hashcode
index-of*
substring
str-reverse
sbuf?
<sbuf>
sbuf-length
@ -277,9 +282,13 @@ IN: cross-compiler
dump
cwd
cd
compile-byte
compile-cell
compile-offset
set-compiled-byte
set-compiled-cell
compiled-offset
set-compiled-offset
literal-top
set-literal-top
address-of
] [
swap succ tuck primitive,
] each drop ;

4
library/platform/jvm/sbuf.factor
View File

@ -58,3 +58,7 @@ USE: stack
: sbuf-reverse ( sbuf -- )
#! Destructively reverse a string buffer.
[ ] "java.lang.StringBuffer" "reverse" jinvoke drop ;
DEFER: str>sbuf
: str-reverse ( str -- str )
str>sbuf dup sbuf-reverse sbuf>str ;

12
library/platform/jvm/stream.factor
View File

@ -112,8 +112,8 @@ USE: strings
#! java.io.OutputStream out. The streams are wrapped in
#! buffered streams.
<stream> [
<bout> "out" set
<bin> "in" set
"out" set
"in" set
( -- string )
[ <byte-stream>/freadln ] "freadln" set
( count -- string )
@ -191,12 +191,12 @@ USE: strings
<char-stream> ;
: <filebr> ( path -- stream )
[ "java.lang.String" ] "java.io.FileInputStream" jnew
[ "java.lang.String" ] "java.io.FileInputStream" jnew <bin>
f
<byte-stream> ;
: <filebw> ( path -- stream )
[ "java.lang.String" ] "java.io.FileOutputStream" jnew
[ "java.lang.String" ] "java.io.FileOutputStream" jnew <bout>
f swap
<byte-stream> ;
@ -232,8 +232,8 @@ USE: strings
: <socket-stream> ( socket -- stream )
#! Wraps a socket inside a byte-stream.
dup
[ [ ] "java.net.Socket" "getInputStream" jinvoke ]
[ [ ] "java.net.Socket" "getOutputStream" jinvoke ]
[ [ ] "java.net.Socket" "getInputStream" jinvoke <bin> ]
[ [ ] "java.net.Socket" "getOutputStream" jinvoke <bout> ]
cleave
<byte-stream> [
dup >str "client" set "socket" set

5
library/platform/native/boot-stage2.factor
View File

@ -109,7 +109,6 @@ USE: stdio
"/library/telnetd.factor"
"/library/inferior.factor"
"/library/platform/native/profiler.factor"
"/library/platform/native/compiler.factor"
"/library/image.factor"
"/library/cross-compiler.factor"
@ -132,6 +131,10 @@ USE: stdio
"/library/jedit/jedit-remote.factor"
"/library/jedit/jedit.factor"
"/library/compiler/assembler.factor"
"/library/compiler/assembly-x86.factor"
"/library/compiler/compiler.factor"
"/library/platform/native/primitives.factor"
"/library/init.factor"

90
library/platform/native/compiler.factor
View File

@ -1,90 +0,0 @@
IN: compiler
USE: math
USE: stack
USE: lists
USE: combinators
USE: words
USE: namespaces
USE: unparser
USE: errors
USE: strings
USE: logic
USE: kernel
: DATASTACK
#! A pointer to a pointer to the datastack top.
11 getenv ;
: EAX 0 ;
: ECX 1 ;
: EDX 2 ;
: EBX 3 ;
: ESP 4 ;
: EBP 5 ;
: ESI 6 ;
: EDI 7 ;
: I>R ( imm reg -- )
#! MOV <imm> TO <reg>
HEX: a1 + compile-byte compile-cell ;
: I>[R] ( imm reg -- )
#! MOV <imm> TO ADDRESS <reg>
HEX: c7 compile-byte compile-byte compile-cell ;
: I+[I] ( imm addr -- )
#! ADD <imm> TO ADDRESS <addr>
HEX: 81 compile-byte
HEX: 05 compile-byte
compile-cell
compile-cell ;
: LITERAL ( cell -- )
#! Push literal on data stack.
DATASTACK EAX I>R EAX I>[R] 4 DATASTACK I+[I] ;
: (JMP) ( xt opcode -- )
#! JMP, CALL insn is 5 bytes long
#! addr is relative to *after* insn
compile-byte compile-offset 4 + - compile-cell ;
: JMP HEX: e9 (JMP) ;
: CALL HEX: e8 (JMP) ;
: RET HEX: c3 compile-byte ;
: compile-word ( word -- )
#! Compile a JMP at the end (tail call optimization)
word-xt "compile-last" get [ JMP ] [ CALL ] ifte ;
: compile-fixnum ( n -- )
3 shift 7 bitnot bitand LITERAL ;
: compile-atom ( obj -- )
[
[ fixnum? ] [ compile-fixnum ]
[ word? ] [ compile-word ]
[ drop t ] [ "Cannot compile " swap unparse cat2 throw ]
] cond ;
: compile-loop ( quot -- )
dup [
unswons
over not "compile-last" set
compile-atom
compile-loop
] [
drop RET
] ifte ;
: compile-quot ( quot -- xt )
[
"compile-last" off
compile-offset swap compile-loop
] with-scope ;
: compile ( word -- )
intern dup word-parameter compile-quot swap set-word-xt ;
: call-xt ( xt -- )
#! For testing.
0 f f <word> [ set-word-xt ] keep execute ;

4
library/platform/native/debugger.factor
View File

@ -92,6 +92,9 @@ USE: words
: bad-primitive-error ( obj -- )
"Bad primitive number: " write . ;
: c-string-error ( obj -- )
"Cannot convert to C string: " write . ;
: kernel-error. ( obj n -- str )
{
expired-port-error
@ -108,6 +111,7 @@ USE: words
profiling-disabled-error
negative-array-size-error
bad-primitive-error
c-string-error
} vector-nth execute ;
: kernel-error? ( obj -- ? )

1
library/platform/native/init.factor
View File

@ -27,6 +27,7 @@
IN: init
USE: combinators
USE: compiler
USE: errors
USE: kernel
USE: namespaces

7
library/platform/native/primitives.factor
View File

@ -40,6 +40,7 @@ USE: stack
USE: vectors
USE: words
USE: unparser
USE: compiler
[
[ execute | " word -- " ]
@ -189,6 +190,12 @@ USE: unparser
[ dump | " obj -- " ]
[ cwd | " -- dir " ]
[ cd | " dir -- " ]
[ set-compiled-byte | " n ptr -- " ]
[ set-compiled-cell | " n ptr -- " ]
[ compiled-offset | " -- ptr " ]
[ set-compiled-offset | " ptr -- " ]
[ literal-top | " -- ptr " ]
[ set-literal-top | " ptr -- " ]
] [
unswons "stack-effect" swap set-word-property
] each

1
library/platform/native/words.factor
View File

@ -58,7 +58,6 @@ USE: stack
global [ "last-word" set ] bind ;
: define-compound ( word def -- )
#! Define a compound word at runtime.
over set-word-parameter
1 swap set-word-primitive ;

3
library/sbuf.factor
View File

@ -101,6 +101,3 @@ USE: stack
: split-n ( n str -- list )
#! Split a string into n-character chunks.
[, 0 -rot (split-n) ,] ;
: str-reverse ( str -- str )
str>sbuf dup sbuf-reverse sbuf>str ;

3
library/strings.factor
View File

@ -124,9 +124,6 @@ USE: stack
dupd str-tail? dup [ nip t ] [ drop f ] ifte ;
: split1 ( string split -- before after )
#! The car of the pair is the string up to the first
#! occurrence of split; the cdr is the remainder of
#! the string.
2dup index-of dup -1 = [
2drop f
] [

1
native/arithmetic.c
View File

@ -27,6 +27,7 @@ CELL to_cell(CELL x)
return s48_bignum_to_long(untag_bignum(x));
default:
type_error(INTEGER_TYPE,x);
return 0;
}
}

54
native/compiler.c
View File

@ -3,21 +3,61 @@
void init_compiler(void)
{
init_zone(&compiling,COMPILE_ZONE_SIZE);
literal_top = compiling.base;
}
void primitive_compile_byte(void)
void check_compiled_offset(CELL offset)
{
bput(compiling.here,to_fixnum(dpop()));
compiling.here++;
if(offset < compiling.base || offset >= compiling.limit)
range_error(F,offset,compiling.limit);
}
void primitive_compile_cell(void)
void primitive_set_compiled_byte(void)
{
put(compiling.here,to_cell(dpop()));
compiling.here += sizeof(CELL);
CELL offset = to_cell(dpop());
BYTE b = to_fixnum(dpop());
check_compiled_offset(offset);
bput(offset,b);
}
void primitive_compile_offset(void)
void primitive_set_compiled_cell(void)
{
CELL offset = to_cell(dpop());
CELL c = to_fixnum(dpop());
check_compiled_offset(offset);
put(offset,c);
}
void primitive_compiled_offset(void)
{
dpush(tag_integer(compiling.here));
}
void primitive_set_compiled_offset(void)
{
CELL offset = to_cell(dpop());
check_compiled_offset(offset);
compiling.here = offset;
}
void primitive_literal_top(void)
{
dpush(tag_integer(literal_top));
}
void primitive_set_literal_top(void)
{
CELL offset = to_cell(dpop());
check_compiled_offset(offset);
literal_top = offset;
}
void collect_literals(void)
{
CELL i = compiling.base;
while(i < literal_top)
{
copy_object((CELL*)i);
i += CELLS;
}
}

11
native/compiler.h
View File

@ -1,6 +1,11 @@
ZONE compiling;
CELL literal_top;
void init_compiler(void);
void primitive_compile_byte(void);
void primitive_compile_cell(void);
void primitive_compile_offset(void);
void primitive_set_compiled_byte(void);
void primitive_set_compiled_cell(void);
void primitive_compiled_offset(void);
void primitive_set_compiled_offset(void);
void primitive_literal_top(void);
void primitive_set_literal_top(void);
void collect_literals(void);

1
native/error.c
View File

@ -50,6 +50,7 @@ void general_error(CELL error, CELL tagged)
fprintf(stderr,"Got type #%ld\n",type_of(
untag_cons(tagged)->cdr));
}
fflush(stderr);
exit(1);
}
throw_error(c);

1
native/error.h
View File

@ -12,6 +12,7 @@
#define ERROR_PROFILING_DISABLED (11<<3)
#define ERROR_NEGATIVE_ARRAY_SIZE (12<<3)
#define ERROR_BAD_PRIMITIVE (13<<3)
#define ERROR_C_STRING (14<<3)
void fatal_error(char* msg, CELL tagged);
void critical_error(char* msg, CELL tagged);

2
native/gc.c
View File

@ -143,6 +143,8 @@ void primitive_gc(void)
scan = active.here = active.base;
collect_roots();
collect_io_tasks();
/* collect literal objects referenced from compiled code */
collect_literals();
while(scan < active.here)
{
gc_debug("scan loop",scan);

7
native/image.c
View File

@ -6,7 +6,7 @@ void load_image(char* filename)
HEADER h;
CELL size;
fprintf(stderr,"Loading %s...",filename);
printf("Loading %s...",filename);
file = fopen(filename,"rb");
if(file == NULL)
@ -30,7 +30,7 @@ void load_image(char* filename)
active.here = active.base + h.size;
fclose(file);
fprintf(stderr," relocating...");
printf(" relocating...");
fflush(stdout);
clear_environment();
@ -40,7 +40,8 @@ void load_image(char* filename)
relocate(h.relocation_base);
fprintf(stderr," done\n");
printf(" done\n");
fflush(stdout);
}
bool save_image(char* filename)

5
native/memory.c
View File

@ -111,3 +111,8 @@ void primitive_allot_profiling(void)
}
#endif
}
void primitive_address_of(void)
{
dpush(tag_object(s48_ulong_to_bignum(dpop())));
}

1
native/memory.h
View File

@ -69,3 +69,4 @@ bool in_zone(ZONE* z, CELL pointer);
void primitive_room(void);
void primitive_allot_profiling(void);
void primitive_address_of(void);

11
native/primitives.c
View File

@ -26,6 +26,7 @@ XT primitives[] = {
primitive_string_hashcode,
primitive_index_of,
primitive_substring,
primitive_string_reverse,
primitive_sbufp,
primitive_sbuf,
primitive_sbuf_length,
@ -153,9 +154,13 @@ XT primitives[] = {
primitive_dump,
primitive_cwd,
primitive_cd,
primitive_compile_byte,
primitive_compile_cell,
primitive_compile_offset
primitive_set_compiled_byte,
primitive_set_compiled_cell,
primitive_compiled_offset,
primitive_set_compiled_offset,
primitive_literal_top,
primitive_set_literal_top,
primitive_address_of
};
CELL primitive_to_xt(CELL primitive)

2
native/primitives.h
View File

@ -1,4 +1,4 @@
extern XT primitives[];
#define PRIMITIVE_COUNT 155
#define PRIMITIVE_COUNT 160
CELL primitive_to_xt(CELL primitive);

24
native/sbuf.c
View File

@ -101,32 +101,18 @@ void primitive_sbuf_append(void)
}
}
STRING* sbuf_to_string(SBUF* sbuf)
{
STRING* string = allot_string(sbuf->top);
memcpy(string + 1,sbuf->string + 1,sbuf->top * CHARS);
hash_string(string);
return string;
}
void primitive_sbuf_to_string(void)
{
drepl(tag_object(sbuf_to_string(untag_sbuf(dpeek()))));
SBUF* sbuf = untag_sbuf(dpeek());
STRING* s = string_clone(sbuf->string,sbuf->top);
hash_string(s);
drepl(tag_object(s));
}
void primitive_sbuf_reverse(void)
{
SBUF* sbuf = untag_sbuf(dpop());
int i, j;
CHAR ch1, ch2;
for(i = 0; i < sbuf->top / 2; i++)
{
j = sbuf->top - i - 1;
ch1 = string_nth(sbuf->string,i);
ch2 = string_nth(sbuf->string,j);
set_string_nth(sbuf->string,j,ch1);
set_string_nth(sbuf->string,i,ch2);
}
string_reverse(sbuf->string,sbuf->top);
}
void primitive_sbuf_clone(void)

1
native/sbuf.h
View File

@ -25,7 +25,6 @@ void set_sbuf_nth(SBUF* sbuf, CELL index, CHAR value);
void primitive_set_sbuf_nth(void);
void sbuf_append_string(SBUF* sbuf, STRING* string);
void primitive_sbuf_append(void);
STRING* sbuf_to_string(SBUF* sbuf);
void primitive_sbuf_to_string(void);
void primitive_sbuf_reverse(void);
void primitive_sbuf_clone(void);

47
native/string.c
View File

@ -80,7 +80,12 @@ BYTE* to_c_string(STRING* s)
BYTE* c_str = (BYTE*)(_c_str + 1);
for(i = 0; i < s->capacity; i++)
{
CHAR ch = string_nth(s,i);
if(ch == '\0' || ch > 255)
general_error(ERROR_C_STRING,tag_object(s));
c_str[i] = string_nth(s,i);
}
c_str[s->capacity] = '\0';
@ -259,3 +264,45 @@ void primitive_substring(void)
CELL start = to_fixnum(dpop());
dpush(tag_object(substring(start,end,string)));
}
/* DESTRUCTIVE - don't use with user-visible strings */
void string_reverse(STRING* s, int len)
{
int i, j;
CHAR ch1, ch2;
for(i = 0; i < len / 2; i++)
{
j = len - i - 1;
ch1 = string_nth(s,i);
ch2 = string_nth(s,j);
set_string_nth(s,j,ch1);
set_string_nth(s,i,ch2);
}
}
/* Doesn't rehash the string! */
STRING* string_clone(STRING* s, int len)
{
STRING* copy = allot_string(len);
memcpy(copy + 1,s + 1,len * CHARS);
return copy;
}
void primitive_string_reverse(void)
{
STRING* s = untag_string(dpeek());
s = string_clone(s,s->capacity);
string_reverse(s,s->capacity);
hash_string(s);
drepl(tag_object(s));
}
STRING* fixup_untagged_string(STRING* str)
{
return (STRING*)((CELL)str + (active.base - relocation_base));
}
STRING* copy_untagged_string(STRING* str)
{
return copy_untagged_object(str,SSIZE(str));
}

15
native/string.h
View File

@ -46,13 +46,8 @@ void primitive_string_eq(void);
void primitive_string_hashcode(void);
void primitive_index_of(void);
void primitive_substring(void);
INLINE STRING* fixup_untagged_string(STRING* str)
{
return (STRING*)((CELL)str + (active.base - relocation_base));
}
INLINE STRING* copy_untagged_string(STRING* str)
{
return copy_untagged_object(str,SSIZE(str));
}
void string_reverse(STRING* s, int len);
STRING* string_clone(STRING* s, int len);
void primitive_string_reverse(void);
STRING* fixup_untagged_string(STRING* str);
STRING* copy_untagged_string(STRING* str);