mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-02-03 14:10:33 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merge NEW_COMPILER 25.05.03

Browse source
This commit is contained in:
jjgarcia 2003-05-26 09:49:50 +00:00
parent a44b509bdc
commit a381a7ee09
64 changed files with 1901 additions and 1606 deletions
Download patch file Download diff file Expand all files Collapse all files

25
src/CHANGELOG
View file

@ -1422,6 +1422,31 @@ ECLS 0.9
etc. That sequence type is used, rather than the general one
(VECTOR T). (:TYPE option from slots is not used, though).
ECLS 1.0
========
* Errors fixed:
- DPP now properly handles &allow_other_keys.
* Visible changes:
- New special form C-INLINE, allows inserting C/C++ code in any
place where a lisp form is allowed.
- New lisp object type, t_foreign, for user-allocated or "foreign"
data; plus routines to simulate the UFFI foreign functions
interface.
- New function SI::FILE-KIND (based on lstat() and stat()) returns
either :DIRECTORY, :FILE, :LINK, :SPECIAL, or NIL (= Non
existent), for a given file name.
* ANSI compatibility:
- DIRECTORY now understands :WILD, :UP, :WILD-INFERIORS, and, as an
extension, other masks within the pathname ("/foo*/**/d*d.l?sp").
It also accepts and ignores all keyword arguments.
TODO:
=====

4
src/Makefile.in
View file

@ -131,8 +131,8 @@ test3:
cp -rf lsp clos cmp stage2
-for i in lsp cmp clos clx tk; do test -f lib$$i.a && mv lib$$i.a stage2; done
$(MAKE) clean_lisp
./ecl < compile2.lsp
for i in lsp clos cmp clx tk; do test -d $$i && diff --exclude=\*.o $$i stage2/$$i; done
./ecl < compile.lsp
-for i in lsp clos cmp clx tk; do test -d $$i && diff --exclude=\*.o $$i stage2/$$i; done | less
test:
make -C tests
make -C ansi-tests > ansi-tests/log

8
src/bare.lsp.in
View file

@ -1,5 +1,9 @@
;;;
;;; Configuration file for the bootstrapping version of ECL
;;; This file can be loaded either in ECL_MIN or in the final executable
;;; ECL. In both cases, it ensures that we have a working Common-Lisp
;;; environment (either interpreted, as in ECL_MIN, or compiled, as in ECL),
;;; that the compiler is loaded, that we use the headers in this directory,
;;; etc.
;;;
;;; * Set ourselves in the 'SYSTEM package
;;;
@ -61,4 +65,4 @@
;;; * Go back to build directory to start compiling
;;;
#+ecl-min
(setq *features* (remove :ecl-min *features*))
(setq *features* (cons :stage1 (remove :ecl-min *features*)))

2
src/c/Makefile.in
View file

@ -43,7 +43,7 @@ OBJS = main.o symbol.o package.o list.o\
time.o unixint.o\
mapfun.o multival.o hash.o format.o pathname.o\
structure.o load.o unixfsys.o unixsys.o \
all_symbols.o @EXTRA_OBJS@
all_symbols.o ffi.o @EXTRA_OBJS@
.SUFFIXES: .c .o .d

10
src/c/alloc.d
View file

@ -393,6 +393,13 @@ ONCE_MORE:
obj->cblock.data_text = NULL;
obj->cblock.data_text_size = 0;
break;
#ifdef ECL_FFI
case t_foreign:
obj->foreign.tag = Cnil;
obj->foreign.size = 0;
obj->foreign.data = NUL;;
break;
#endif ECL_FFI
default:
printf("\ttype = %d\n", t);
error("alloc botch.");
@ -719,6 +726,9 @@ init_alloc(void)
init_tm(t_instance, "IINSTANCE", sizeof(struct instance), 32);
init_tm(t_gfun, "GGFUN", sizeof(struct gfun), 32);
#endif /* CLOS */
#ifdef ECL_FFI
init_tm(t_foreign, "LFOREIGN", sizeof(struct foreign), 1);
#endif
#ifdef THREADS
init_tm(t_cont, "?CONT", sizeof(struct cont), 2);
init_tm(t_thread, "tTHREAD", sizeof(struct thread), 2);

3
src/c/alloc_2.d
View file

@ -173,6 +173,9 @@ init_alloc(void)
init_tm(t_instance, "INSTANCE", sizeof(struct instance));
init_tm(t_gfun, "GFUN", sizeof(struct gfun));
#endif /* CLOS */
#ifdef ECL_FFI
init_tm(t_instance, "FOREIGN", sizeof(struct foreign));
#endif
#ifdef THREADS
init_tm(t_cont, "CONT", sizeof(struct cont));
init_tm(t_thread, "THREAD", sizeof(struct thread));

7
src/c/compiler.d
View file

@ -2378,10 +2378,13 @@ static void
c_default(cl_index deflt_pc) {
cl_object deflt = asm_ref(deflt_pc);
cl_type t = type_of(deflt);
if ((t == t_symbol) && (deflt->symbol.stype == stp_constant))
if (((t == t_symbol) && (deflt->symbol.stype == stp_constant) &&
!FIXNUMP(SYM_VAL(deflt)))) {
/* FIXME! Shouldn't this happen only in unsafe mode */
asm_at(deflt_pc, SYM_VAL(deflt));
else if ((t == t_symbol) || (t == t_cons) || (t == t_fixnum)) {
} else if (CONSP(deflt) && (CAR(deflt) == @'quote') && !FIXNUMP(CADR(deflt))) {
asm_at(deflt_pc, CADR(deflt));
} else if ((t == t_symbol) || (t == t_cons) || (t == t_fixnum)) {
cl_index pc = current_pc();
asm_at(deflt_pc, MAKE_FIXNUM(pc-deflt_pc));
compile_form(deflt, FLAG_VALUES);

2
src/c/dpp.c
View file

@ -618,7 +618,7 @@ put_declaration(void)
put_lineno();
fprintf(out, "\tbool %s;\n", optional[i].o_svar);
}
if (nkey > 0) {
if (key_flag) {
put_lineno();
fprintf(out, "\tstatic cl_object KEYS[%d] = {", nkey);
for (i = 0; i < nkey; i++) {

59
src/c/ffi.d Normal file
View file

@ -0,0 +1,59 @@
/*
ffi.c -- User defined data types and foreign functions interface.
*/
/*
Copyright (c) 2001, Juan Jose Garcia Ripoll.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
#include "ecl.h"
#ifdef ECL_FFI
cl_object
si_allocate_foreign_data(cl_object tag, cl_object size)
{
cl_object output = cl_alloc_object(t_foreign);
cl_index bytes = fixnnint(size);
output->foreign.tag = tag;
output->foreign.size = bytes;
output->foreign.data = bytes? cl_alloc_atomic(bytes) : NULL;
@(return output)
}
cl_object
si_free_foreign_data(cl_object f)
{
if (type_of(f) != t_foreign)
FEwrong_type_argument(@'si::foreign-data', f);
if (f->foreign.size)
cl_dealloc(f->foreign.data, f->foreign.size);
f->foreign.size = 0;
f->foreign.data = NULL;
}
cl_object
si_foreign_data_tag(cl_object f)
{
if (type_of(f) != t_foreign)
FEwrong_type_argument(@'si::foreign-data', f);
@(return f->foreign.tag);
}
cl_object
ecl_make_foreign_data(cl_object tag, cl_index size, void *data)
{
cl_object output = cl_alloc_object(t_foreign);
output->foreign.tag = tag;
output->foreign.size = size;
output->foreign.data = (char*)data;
return output;
}
#endif /* ECL_FFI */

35
src/c/file.d
View file

@ -826,7 +826,10 @@ BEGIN:
case smm_input:
if (fp == NULL)
wrong_file_handler(strm);
fseek(fp, 0L, 2);
while (flisten(fp)) {
int c;
GETC(c, fp);
}
break;
case smm_synonym:
@ -993,6 +996,23 @@ BEGIN:
}
}
static bool
flisten(FILE *fp)
{
if (feof(fp))
return(FALSE);
if (FILE_CNT(fp) > 0)
return(TRUE);
#ifdef FIONREAD
{ long c = 0;
ioctl(fileno(fp), FIONREAD, &c);
if (c <= 0)
return(FALSE);
}
#endif /* FIONREAD */
return(TRUE);
}
bool
listen_stream(cl_object strm)
{
@ -1017,18 +1037,7 @@ BEGIN:
fp = strm->stream.file;
if (fp == NULL)
wrong_file_handler(strm);
if (feof(fp))
return(FALSE);
if (FILE_CNT(fp) > 0)
return(TRUE);
#ifdef FIONREAD
{ long c = 0;
ioctl(fileno(fp), FIONREAD, &c);
if (c <= 0)
return(FALSE);
}
#endif /* FIONREAD */
return(TRUE);
return flisten(fp);
case smm_synonym:
strm = symbol_value(strm->stream.object0);

7
src/c/gbc.d
View file

@ -404,6 +404,13 @@ BEGIN:
}
mark_next(x->cblock.next);
break;
#ifdef ECL_FFI
case t_foreign:
if (x->foreign.size)
mark_contblock(x->foreign.data, x->foreign.size);
mark_next(x->foreign.tag);
break;
#endif ECL_FFI
default:
if (debug)
printf("\ttype = %d\n", type_of(x));

2
src/c/instance.d
View file

@ -121,7 +121,7 @@ si_instance_ref_safe(cl_object x, cl_object index)
x = x->instance.slots[i];
if (x == OBJNULL)
FEerror("Slot index ~S unbound", 1, index);
@(return x->instance.slots[i])
@(return x)
}
cl_object

8
src/c/load.d
View file

@ -87,10 +87,9 @@ si_load_source(cl_object source, cl_object verbose, cl_object print)
@(return Cnil)
}
CL_UNWIND_PROTECT_BEGIN {
bds_bind(@'*standard-input*', strm);
for (;;) {
cl_object bytecodes = Cnil;
x = read_object_non_recursive(strm);
x = cl_read(3, strm, Cnil, OBJNULL);
if (x == OBJNULL)
break;
eval(x, &bytecodes, Cnil);
@ -99,7 +98,6 @@ si_load_source(cl_object source, cl_object verbose, cl_object print)
@terpri(0);
}
}
bds_unwind1;
} CL_UNWIND_PROTECT_EXIT {
/* We do not want to come back here if close_stream fails,
therefore, first we frs_pop() current jump point, then
@ -136,7 +134,7 @@ si_load_source(cl_object source, cl_object verbose, cl_object print)
/* If filename already has an extension, make sure
that the file exists */
filename = coerce_to_filename(pathname);
if (!file_exists(filename)) {
if (si_file_kind(filename, Ct) != @':file') {
filename = Cnil;
} else {
function = cl_cdr(assoc(pathname->pathname.type, hooks));
@ -147,7 +145,7 @@ si_load_source(cl_object source, cl_object verbose, cl_object print)
pathname->pathname.type = CAAR(hooks);
filename = coerce_to_filename(pathname);
function = CDAR(hooks);
if (file_exists(filename))
if (si_file_kind(filename, Ct) == @':file')
break;
else
filename = Cnil;

4
src/c/main.d
View file

@ -259,6 +259,10 @@ init_main(void)
ADD_FEATURE("PDE");
#endif
#ifdef ECL_FFI
ADD_FEATURE("FFI");
#endif
#ifdef unix
ADD_FEATURE("UNIX");
#endif

103
src/c/pathname.d
View file

@ -38,6 +38,54 @@ error_directory(cl_object d) {
FEerror("make-pathname: ~A is not a valid directory", 1, d);
}
static cl_object
check_directory(cl_object directory, bool logical)
{
cl_object ptr, item;
int i;
if (CAR(directory) != @':absolute' && CAR(directory) != @':relative')
return Cnil;
BEGIN:
for (i=0, ptr=directory; !endp(ptr); ptr = CDR(ptr), i++) {
cl_object item = CAR(ptr);
if (item == @':back') {
if (i == 0)
return @':error';
if (i == 1)
return @':error';
item = nthcdr(i-1, directory);
if (item == @':absolute' || item == @':wild-inferiors')
return @':error';
if (i > 2)
CDR(nthcdr(i-2, directory)) = CDR(ptr);
} if (item == @':up') {
if (i == 0)
return @':error';
item = nthcdr(i-1, directory);
if (item == @':absolute' || item == @':wild-inferiors')
return @':error';
} else if (item == @':relative' || item == @':absolute') {
if (i > 0)
return @':error';
} else if (type_of(item) == t_string) {
if (logical)
continue;
if (strcmp(item->string.self,".")==0) {
if (i == 0)
return @':error';
CDR(nthcdr(i-1, directory)) = CDR(ptr);
} else if (strcmp(item->string.self,"..") == 0) {
CAR(directory) = @':back';
goto BEGIN;
}
} else if (item != @':wild' && item != @':wild-inferiors') {
return @':error';
}
}
return directory;
}
cl_object
make_pathname(cl_object host, cl_object device, cl_object directory,
cl_object name, cl_object type, cl_object version)
@ -55,10 +103,13 @@ make_pathname(cl_object host, cl_object device, cl_object directory,
directory = cl_list(2, @':absolute', @':wild-inferiors');
error_directory(directory);
break;
case t_cons:
if (CAR(directory) == @':absolute' ||
CAR(directory) == @':relative')
case t_cons: {
cl_object aux = check_directory(cl_copy_list(directory), 1);
if (aux != @':error') {
directory = aux;
break;
}
}
default:
error_directory(directory);
@ -88,7 +139,6 @@ make_pathname(cl_object host, cl_object device, cl_object directory,
return(x);
}
static cl_object
tilde_expand(cl_object directory)
{
@ -216,19 +266,19 @@ parse_directories(const char *s, int flags, cl_index start, cl_index end,
flags |= WORD_INCLUDE_DELIM | WORD_ALLOW_ASTERISK;
*end_of_dir = start;
for (i = j = start; i < end; j = i) {
cl_object word = parse_word(s, delim, flags, j, end, &i);
if (word == @':error' || word == Cnil)
cl_object part = parse_word(s, delim, flags, j, end, &i);
if (part == @':error' || part == Cnil)
break;
if (word == null_string) { /* just "/" or ";" */
if (part == null_string) { /* "/", ";" */
if (j != start) {
if (flags & WORD_LOGICAL)
return @':error';
continue;
}
word = (flags & WORD_LOGICAL) ? @':relative' : @':absolute';
part = (flags & WORD_LOGICAL) ? @':relative' : @':absolute';
}
*end_of_dir = i;
plast = &CDR(*plast = CONS(word, Cnil));
plast = &CDR(*plast = CONS(part, Cnil));
}
return path;
}
@ -295,10 +345,13 @@ parse_namestring(const char *s, cl_index start, cl_index end, cl_index *ep,
logical = TRUE;
device = Cnil;
path = parse_directories(s, WORD_LOGICAL, *ep, end, ep);
if (CONSP(path)) {
if (CAR(path) != @':relative' && CAR(path) != @':absolute')
path = CONS(@':absolute', path);
path = check_directory(path, TRUE);
}
if (path == @':error')
return Cnil;
if (!endp(path) && CAR(path) != @':relative')
path = CONS(@':absolute', path);
name = parse_word(s, '.', WORD_LOGICAL | WORD_ALLOW_ASTERISK |
WORD_EMPTY_IS_NIL, *ep, end, ep);
type = parse_word(s, '\0', WORD_LOGICAL | WORD_ALLOW_ASTERISK |
@ -338,22 +391,14 @@ parse_namestring(const char *s, cl_index start, cl_index end, cl_index *ep,
return Cnil;
}
path = parse_directories(s, 0, *ep, end, ep);
if (CONSP(path)) {
if (CAR(path) != @':relative' && CAR(path) != @':absolute')
path = CONS(@':relative', path);
path = tilde_expand(path);
path = check_directory(path, FALSE);
}
if (path == @':error')
return Cnil;
if (!endp(path)) {
if (CAR(path) == @':absolute') {
/* According to ANSI CL, "/.." is erroneous */
if (cl_cadr(path) == @':up')
return Cnil;
} else {
/* If path is relative and we got here, then it
has no :RELATIVE/:ABSOLUTE in front of it and we add one.
Pathnames with hostnames are always absolute.
*/
path = CONS(host == Cnil? @':relative' : @':absolute', path);
path = tilde_expand(path);
}
}
name = parse_word(s, '.', WORD_ALLOW_ASTERISK | WORD_EMPTY_IS_NIL, *ep,
end, ep);
type = parse_word(s, '\0', WORD_ALLOW_ASTERISK | WORD_EMPTY_IS_NIL, *ep,
@ -607,8 +652,10 @@ do_namestring(cl_object x)
push_c_string(buffer, "*", 1);
} else if (y == @':wild-inferiors') {
push_c_string(buffer, "**", 2);
} else {
} else if (y != @':back') {
push_string(buffer, y);
} else {
FEerror("Directory :back has no namestring representation",0);
}
push_c_string(buffer, logical? ";" : "/", 1);
}
@ -910,9 +957,9 @@ do_path_item_match(const char *s, const char *p) {
static bool
path_item_match(cl_object a, cl_object mask) {
if (mask == @':wild' || mask == Cnil)
if (mask == @':wild')
return TRUE;
if (type_of(a) != t_string)
if (type_of(a) != t_string || mask == Cnil)
return (a == mask);
if (type_of(mask) != t_string)
FEerror("~S is not supported as mask for pathname-match-p", 1, mask);

11
src/c/print.d
View file

@ -1173,7 +1173,7 @@ _write_object(cl_object x, int level)
case t_bytecodes: {
cl_object name = x->bytecodes.name;
if (PRINTreadably) FEprint_not_readable(x);
write_str("#<interpreted-function ");
write_str("#<bytecompiled-function ");
if (name != Cnil)
_write_object(name, level);
else
@ -1239,6 +1239,15 @@ _write_object(cl_object x, int level)
write_ch('>');
break;
#endif /* CLOS */
#ifdef ECL_FFI
case t_foreign:
if (PRINTreadably) FEprint_not_readable(x);
write_str("#<foreign ");
/*_write_object(x->foreign.tag, level);*/
write_addr(x->foreign.data);
write_ch('>');
break;
#endif /* ECL_FFI */
default:
if (PRINTreadably) FEprint_not_readable(x);
write_str("#<illegal pointer ");

15
src/c/symbols_list.h
View file

@ -1038,7 +1038,7 @@ cl_symbols[] = {
{SYS_ "ELT-SET", SI_ORDINARY, si_elt_set, 3},
{SYS_ "EVAL-WITH-ENV", SI_ORDINARY, si_eval_with_env, 2},
{SYS_ "EXPAND-DEFMACRO", SI_ORDINARY, NULL, -1},
{SYS_ "FILE-EXISTS", SI_ORDINARY, si_file_exists, 1},
{SYS_ "FILE-KIND", SI_ORDINARY, si_file_kind, 2},
{SYS_ "FILL-POINTER-SET", SI_ORDINARY, si_fill_pointer_set, 2},
{SYS_ "FIXNUMP", SI_ORDINARY, si_fixnump, 1},
{SYS_ "FRS-BDS", SI_ORDINARY, si_frs_bds, 1},
@ -1119,7 +1119,6 @@ cl_symbols[] = {
{SYS_ "SPECIALP", SI_ORDINARY, si_specialp, 1},
{SYS_ "STANDARD-READTABLE", SI_ORDINARY, si_standard_readtable, 0},
{SYS_ "STRING-CONCATENATE", SI_ORDINARY, si_string_concatenate, -1},
{SYS_ "STRING-MATCH", SI_ORDINARY, si_string_match, 2},
{SYS_ "STRING-TO-OBJECT", SI_ORDINARY, si_string_to_object, 1},
{SYS_ "STRUCTURE-NAME", SI_ORDINARY, si_structure_name, 1},
{SYS_ "STRUCTURE-PRINT-FUNCTION", SI_ORDINARY, NULL, -1},
@ -1247,6 +1246,7 @@ cl_symbols[] = {
{KEY_ "ALLOW-OTHER-KEYS", KEYWORD, NULL, -1},
{KEY_ "APPEND", KEYWORD, NULL, -1},
{KEY_ "ARRAY", KEYWORD, NULL, -1},
{KEY_ "BACK", KEYWORD, NULL, -1},
{KEY_ "BASE", KEYWORD, NULL, -1},
{KEY_ "BLOCK", KEYWORD, NULL, -1},
{KEY_ "CAPITALIZE", KEYWORD, NULL, -1},
@ -1353,6 +1353,17 @@ cl_symbols[] = {
{SYS_ "VALID-FUNCTION-NAME-P", SI_ORDINARY, si_valid_function_name_p, 1},
#ifdef ECL_FFI
{SYS_ "ALLOCATE-FOREIGN-DATA", SI_ORDINARY, si_allocate_foreign_data, 2},
{SYS_ "FOREIGN-DATA", SI_ORDINARY, NULL, -1},
{SYS_ "FOREIGN-DATA-TAG", SI_ORDINARY, si_foreign_data_tag, 1},
{SYS_ "FREE-FOREIGN-DATA", SI_ORDINARY, si_free_foreign_data, 1},
#endif
{KEY_ "FILE", KEYWORD, NULL, -1},
{KEY_ "LINK", KEYWORD, NULL, -1},
{KEY_ "SPECIAL", KEYWORD, NULL, -1},
/* Tag for end of list */
{NULL, CL_ORDINARY, NULL, -1}};

5
src/c/typespec.d
View file

@ -362,7 +362,10 @@ cl_type_of(cl_object x)
case t_gfun:
t = @'dispatch-function'; break;
#endif
#ifdef ECL_FFI
case t_foreign:
t = @'si::foreign-data'; break;
#endif
default:
error("not a lisp data object");
}

509
src/c/unixfsys.d
View file

@ -21,6 +21,7 @@
#include <sys/stat.h>
#include <stdlib.h>
#include "ecl.h"
#include "ecl-inl.h"
#include "machines.h"
#ifdef BSD
#include <dirent.h>
@ -77,24 +78,54 @@ current_dir(void) {
* Using a certain path, guess the type of the object it points to.
*/
enum file_system_type {
FILE_DOES_NOT_EXIST = 0,
FILE_REGULAR = 1,
FILE_DIRECTORY = 2,
FILE_OTHER = 3
};
static cl_object
file_kind(char *filename, bool follow_links) {
struct stat buf;
if ((follow_links? stat : lstat)(filename, &buf) < 0)
return Cnil;
if (S_ISLNK(buf.st_mode))
return @':link';
if (S_ISDIR(buf.st_mode))
return @':directory';
if (S_ISREG(buf.st_mode))
return @':file';
return @':special';
}
static int
get_file_system_type(const char *namestring) {
struct stat buf;
cl_object
si_file_kind(cl_object filename, cl_object follow_links) {
filename = coerce_to_filename(filename);
if (stat(namestring, &buf) < 0)
return FILE_DOES_NOT_EXIST;
if (S_ISREG(buf.st_mode))
return FILE_REGULAR;
if (S_ISDIR(buf.st_mode))
return FILE_DIRECTORY;
return FILE_OTHER;
@(return file_kind(filename->string.self, !Null(follow_links)))
}
static cl_object
si_follow_symlink(cl_object filename) {
cl_object output, kind;
int size = 128, written;
output = coerce_to_filename(filename);
kind = file_kind(output->string.self, FALSE);
while (kind == @':link') {
cl_object aux;
do {
aux = cl_alloc_adjustable_string(size);
written = readlink(output->string.self, aux->string.self, size);
size += 256;
} while(written == size);
aux->string.self[written] = '\0';
output = aux;
kind = file_kind(output->string.self, FALSE);
if (kind == @':directory') {
output->string.self[written++] = '/';
output->string.self[written] = '\0';
}
output->string.fillp = written;
}
if (kind == @':directory' &&
output->string.self[output->string.fillp-1] != '/')
FEerror("Filename ~S actually points to a directory", 1, filename);
@(return ((kind == Cnil)? Cnil : output))
}
@ -103,94 +134,26 @@ get_file_system_type(const char *namestring) {
* going through links if they exist. Default is
* current directory
*/
static cl_object
error_no_dir(cl_object pathname) {
FElibc_error("truedirectory: ~S cannot be accessed", 1, pathname);
return Cnil;
}
static cl_object
truedirectory(cl_object pathname)
{
cl_object directory;
directory = current_dir();
if (pathname->pathname.directory != Cnil) {
cl_object dir = pathname->pathname.directory;
if (CAR(dir) == @':absolute')
chdir("/");
for (dir=CDR(dir); !Null(dir); dir=CDR(dir)) {
cl_object name = CAR(dir);
if (name == @':up') {
if (chdir("..") < 0)
return error_no_dir(pathname);
} else if (type_of(name) == t_string) {
name = coerce_to_simple_string(name);
if (chdir(name->string.self) < 0)
return error_no_dir(pathname);
} else
FEerror("truename: ~A not allowed in filename",1,name);
}
dir = current_dir();
chdir(directory->string.self);
directory = dir;
}
return directory;
}
cl_object
cl_truename(cl_object pathname)
{
cl_object directory;
cl_object truefilename;
cl_object directory, filename;
pathname = coerce_to_file_pathname(pathname);
/* First we ensure that PATHNAME itself does not point to a symlink. */
filename = si_follow_symlink(pathname);
if (filename == Cnil)
FEerror("truename: file ~S does not exist or cannot be accessed", 1,
pathname);
/* We are looking for a file! */
if (pathname->pathname.name == Cnil)
FEerror("truename: no file name supplied",0);
/* Next we process the directory part of the filename, removing all
* possible symlinks. To do so, we only have to change to the directory
* which contains our file, and come back. SI::CHDIR calls getcwd() which
* should return the canonical form of the directory.
*/
directory = si_chdir(filename);
directory = si_chdir(directory);
/* Wildcards are not allowed */
if (pathname->pathname.name == @':wild' ||
pathname->pathname.type == @':wild')
FEerror("truename: :wild not allowed in filename",0);
directory = truedirectory(pathname);
/* Compose a whole pathname by adding the
file name and the file type */
if (Null(pathname->pathname.type))
truefilename = @si::string-concatenate(2, directory, pathname->pathname.name);
else {
truefilename = @si::string-concatenate(4, directory,
pathname->pathname.name,
make_simple_string("."),
pathname->pathname.type);
}
/* Finally check that the object exists and it is
either a file or a device. (FIXME! Should we
reject devices, pipes, etc?) */
switch (get_file_system_type(truefilename->string.self)) {
case FILE_DOES_NOT_EXIST:
FEerror("truename: file does not exist or cannot be accessed",1,pathname);
case FILE_DIRECTORY:
FEerror("truename: ~A is a directory", 1, truefilename);
default:
return1(cl_pathname(truefilename));
}
}
bool
file_exists(cl_object file)
{
struct stat filestatus;
file = coerce_to_filename(file);
if (stat(file->string.self, &filestatus) >= 0)
return(TRUE);
else
return(FALSE);
@(return merge_pathnames(directory, filename, @':newest'))
}
FILE *
@ -246,15 +209,7 @@ cl_delete_file(cl_object file)
cl_object
cl_probe_file(cl_object file)
{
/* INV: file_exists() and truename() check types */
@(return (file_exists(file)? cl_truename(file) : Cnil))
}
cl_object
si_file_exists(cl_object file)
{
/* INV: file_exists() */
@(return (file_exists(file)? Ct : Cnil))
@(return (si_file_kind(file, Ct) != Cnil? cl_truename(file) : Cnil))
}
cl_object
@ -421,157 +376,247 @@ string_match(const char *s, const char *p) {
return (*p == 0);
}
cl_object
si_string_match(cl_object s1, cl_object s2)
{
assert_type_string(s1);
assert_type_string(s2);
@(return (string_match(s1->string.self, s2->string.self) ? Ct : Cnil))
}
static cl_object
actual_directory(cl_object namestring, cl_object mask, bool all)
{
cl_object ret = Cnil;
cl_object saved_dir = current_dir();
cl_object *directory = &ret;
cl_object dir_path = coerce_to_file_pathname(namestring);
enum file_system_type t;
#if defined(BSD)
/*
* version by Brian Spilsbury <brian@@bizo.biz.usyd.edu.au>, using opendir()
* arranged by Juan Jose Garcia Ripoll to understand masks
* list_current_directory() lists the files and directories which are contained
* in the current working directory (as given by current_dir()). If ONLY_DIR is
* true, the list is made of only the directories -- a propert which is checked
* by following the symlinks.
*/
static cl_object
list_current_directory(const char *mask, bool only_dir)
{
cl_object kind, out = Cnil;
cl_object *out_cdr = &out;
char *text;
#if defined(BSD)
DIR *dir;
struct dirent *entry;
namestring = coerce_to_simple_string(namestring);
mask = coerce_to_simple_string(mask);
if (chdir(namestring->string.self) < 0) {
chdir(saved_dir->string.self);
FElibc_error("directory: cannot access ~A", 1, namestring);
}
dir = opendir(".");
if (dir == NULL) {
chdir(saved_dir->string.self);
FElibc_error("Can't open the directory ~S.", 1, dir);
}
dir = opendir("./");
if (dir == NULL)
return Cnil;
while ((entry = readdir(dir))) {
t = (enum file_system_type)get_file_system_type(entry->d_name);
if ((all || t == FILE_REGULAR) &&
string_match(entry->d_name, mask->string.self))
{
cl_index e = strlen(entry->d_name);
cl_object file = parse_namestring(entry->d_name, 0, e, &e, Cnil);
file = merge_pathnames(dir_path, file,Cnil);
*directory = CONS(file, Cnil);
directory = &CDR(*directory);
}
}
closedir(dir);
#endif
#if defined(SYSV)
text = entry->d_name;
#else /* SYSV */
FILE *fp;
char iobuffer[BUFSIZ];
DIRECTORY dir;
namestring = coerce_to_simple_string(namestring);
mask = coerce_to_simple_string(mask);
if (chdir(namestring->string.self) < 0) {
chdir(saved_dir->string.self);
FElibc_error("directory: cannot access ~A",1,namestring);
}
fp = fopen(".", OPEN_R);
if (fp == NULL) {
chdir(saved_dir->string.self);
FElibc_error("Can't open the directory ~S.", 1, dir);
}
previous_dir = si_chdir(directory);
fp = fopen("./", OPEN_R);
if (fp == NULL)
return Cnil;
setbuf(fp, iobuffer);
/* FIXME! What are these three lines for? */
fread(&dir, sizeof(DIRECTORY), 1, fp);
fread(&dir, sizeof(DIRECTORY), 1, fp);
for (;;) {
if (fread(&dir, sizeof(DIRECTORY), 1, fp) <= 0)
break;
if (dir.d_ino == 0)
continue;
t = get_file_system_type(dir.d_name);
if ((all || t == FILE_REGULAR) &&
string_match(dir.d_name, mask->string.self))
{
cl_index e = strlen(dir.d_name);
cl_object file = parse_namestring(dir.d_name, 0, e, &e);
file = merge_pathnames(dir_path, file,Cnil);
*directory = CONS(file, Cnil);
directory = &CDR(*directory);
}
if (fread(&dir, sizeof(DIRECTORY), 1, fp) <= 0)
break;
if (dir.d_ino == 0)
continue;
text = dir.d_name;
#endif
if (text[0] == '.' &&
(text[1] == '\0' ||
(text[1] == '.' && text[2] == '\0')))
continue;
if (only_dir && file_kind(text, TRUE) != @':directory')
continue;
if (mask && !string_match(text, mask))
continue;
*out_cdr = CONS(make_string_copy(text), Cnil);
out_cdr = &CDR(*out_cdr);
}
#ifdef BSD
closedir(dir);
#else
fclose(fp);
#endif
chdir(saved_dir->string.self);
return ret;
return out;
}
@(defun directory (&optional (filemask OBJNULL)
(kall OBJNULL))
cl_object directory;
cl_object name, type, mask;
bool all = FALSE;
/*
* dir_files() lists all files which are contained in the current directory and
* which match the masks in PATHNAME. This routine is essentially a wrapper for
* list_current_directory(), which transforms the list of strings into a list
* of pathnames. BASEDIR is the truename of the current directory and it is
* used to build these pathnames.
*/
static cl_object
dir_files(cl_object basedir, cl_object pathname)
{
cl_object all_files, output = Cnil;
cl_object mask, name, type;
int everything;
name = pathname->pathname.name;
type = pathname->pathname.type;
if (name != Cnil || type != Cnil) {
mask = make_pathname(Cnil, Cnil, Cnil, name, type, @':unspecific');
} else {
mask = Cnil;
}
all_files = list_current_directory(NULL, FALSE);
loop_for_in(all_files) {
char *text = CAR(all_files)->string.self;
if (file_kind(text, TRUE) == @':directory') {
if (mask == Cnil) {
cl_object new = nconc(cl_copy_list(basedir->pathname.directory),
CONS(CAR(all_files), Cnil));
new = make_pathname(basedir->pathname.host,
basedir->pathname.device,
new, Cnil, Cnil, Cnil);
output = CONS(new, output);
}
} else {
cl_object new = cl_pathname(CAR(all_files));
if (mask != Cnil && Null(cl_pathname_match_p(new, mask)))
continue;
if (file_kind(text, FALSE) == @':link')
new = cl_truename(CAR(all_files));
else {
new->pathname.host = basedir->pathname.host;
new->pathname.device = basedir->pathname.device;
new->pathname.directory = basedir->pathname.directory;
}
output = CONS(new, output);
}
} end_loop_for_in;
return output;
}
/*
* dir_recursive() performs the dirty job of DIRECTORY. The routine moves
* through the filesystem looking for files and directories which match
* the masks in the arguments PATHNAME and DIRECTORY, collecting them in a
* list.
*/
static cl_object
dir_recursive(cl_object pathname, cl_object directory)
{
cl_object item, next_dir, prev_dir = current_dir(), output = Cnil;
/* There are several possibilities here:
*
* 1) The list of subdirectories DIRECTORY is empty, and only PATHNAME
* remains to be inspected. If there is no file name or type, then
* we simply output the truename of the current directory. Otherwise
* we have to find a file which corresponds to the description.
*/
if (directory == Cnil) {
prev_dir = cl_pathname(prev_dir);
return dir_files(prev_dir, pathname);
}
/*
* 2) We have not yet exhausted the DIRECTORY component of the
* pathname. We have to enter some subdirectory, determined by
* CAR(DIRECTORY) and scan it.
*/
item = CAR(directory);
if (type_of(item) == t_string || item == @':wild') {
/*
* 2.1) If CAR(DIRECTORY) is a string or :WILD, we have to
* enter & scan all subdirectories in our curent directory.
*/
next_dir = list_current_directory((item == @':wild')? "*" :
item->string.self, TRUE);
loop_for_in(next_dir) {
char *text = CAR(next_dir)->string.self;
/* We are unable to move into this directory! */
if (chdir(text) < 0)
continue;
item = dir_recursive(pathname, CDR(directory));
output = nconc(item, output);
chdir(prev_dir->string.self);
} end_loop_for_in;
} else if (item == @':absolute') {
/*
* 2.2) If CAR(DIRECTORY) is :ABSOLUTE, we have to scan the
* root directory.
*/
if (chdir("/") < 0)
return Cnil;
output = dir_recursive(pathname, CDR(directory));
chdir(prev_dir->string.self);
} else if (item == @':relative') {
/*
* 2.3) If CAR(DIRECTORY) is :RELATIVE, we have to scan the
* current directory.
*/
output = dir_recursive(pathname, CDR(directory));
} else if (item == @':up') {
/*
* 2.4) If CAR(DIRECTORY) is :UP, we have to scan the directory
* which contains this one.
*/
if (chdir("..") < 0)
return Cnil;
output = dir_recursive(pathname, CDR(directory));
chdir(prev_dir->string.self);
} else if (item == @':wild-inferiors') {
/*
* 2.5) If CAR(DIRECTORY) is :WILD-INFERIORS, we have to do
* scan all subdirectories from _all_ levels, looking for a
* tree that matches the remaining part of DIRECTORY.
*/
next_dir = list_current_directory("*", TRUE);
loop_for_in(next_dir) {
char *text = CAR(next_dir)->string.self;
if (chdir(text) < 0)
continue;
item = dir_recursive(pathname, directory);
output = nconc(item, output);
chdir(prev_dir->string.self);
} end_loop_for_in;
output = nconc(output, dir_recursive(pathname, CDR(directory)));
}
return output;
}
@(defun directory (mask &key &allow_other_keys)
cl_object prev_dir = Cnil;
cl_object output;
@
/* Without arguments, it justs lists all files in
current directory */
if (filemask == OBJNULL) {
directory = current_dir();
mask = make_simple_string("*");
goto DO_MATCH;
}
if (kall == @':list-all')
all = TRUE;
else if (kall != OBJNULL)
FEwrong_type_argument(@'keyword', kall);
/* INV: coerce_to_file_pathname() checks types */
filemask = coerce_to_file_pathname(filemask);
name = filemask->pathname.name;
type = filemask->pathname.type;
directory = truedirectory(filemask);
if (name == @':wild')
name = make_simple_string("*");
else if (name == Cnil) {
if (type == Cnil)
name = make_simple_string("*");
else
name = null_string;
}
if (type == Cnil)
mask = name;
else {
cl_object dot = make_simple_string(".");
if (type == @':wild')
type = make_simple_string("*");
mask = @si::string-concatenate(3, name, dot, type);
}
DO_MATCH:
@(return actual_directory(directory, mask, all))
CL_UNWIND_PROTECT_BEGIN {
prev_dir = current_dir();
mask = coerce_to_file_pathname(mask);
output = dir_recursive(mask, mask->pathname.directory);
} CL_UNWIND_PROTECT_EXIT {
if (prev_dir != Cnil)
chdir(prev_dir->string.self);
} CL_UNWIND_PROTECT_END;
@(return output)
@)
cl_object
si_chdir(cl_object directory)
{
cl_object filename, previous;
cl_object previous = current_dir();
cl_object dir;
/* INV: coerce_to_filename() checks types */
filename = coerce_to_filename(directory);
previous = current_dir();
if (chdir(filename->string.self) < 0) {
FElibc_error("Can't change the current directory to ~S", 1,
filename);
directory = coerce_to_file_pathname(directory);
for (dir = directory->pathname.directory; !Null(dir); dir = CDR(dir)) {
cl_object part = CAR(dir);
if (type_of(part) == t_string) {
if (chdir(part->string.self) < 0)
goto ERROR;
} else if (part == @':absolute') {
if (chdir("/") < 0) {
chdir(previous->string.self);
ERROR: FElibc_error("Can't change the current directory to ~S",
1, directory);
}
} else if (part == @':relative') {
/* Nothing to do */
} else if (part == @':up') {
if (chdir("..") < 0)
goto ERROR;
} else {
FEerror("~S is not allowed in SI::CHDIR", 1, part);
}
}
@(return previous)
}

2
src/clos/print.lsp
View file

@ -16,7 +16,7 @@
(defmethod print-object ((instance t) stream)
(print-unreadable-object (instance stream)
(format stream "a ~A"
(si:instance-ref (si:instance-class instance) 0)))
(class-name (si:instance-class instance))))
instance)
(defmethod print-object ((class class) stream)

58
src/cmp/cmpbind.lsp
View file

@ -31,37 +31,34 @@
(setq var-loc (next-env))
(setf (var-loc var) var-loc))
(when (zerop var-loc) (wt-nl "env" *env-lvl* " = Cnil;"))
(wt-nl "CLV" var-loc
"=&CAR(env" *env-lvl* "=CONS(" loc ",env" *env-lvl* "));"))
(wt-nl "CLV" var-loc "=&CAR(env" *env-lvl* "=CONS(")
(wt-coerce-loc :object loc)
(wt ",env" *env-lvl* "));"))
(progn
(unless (consp var-loc)
;; first binding: assign location
(setq var-loc (next-lex))
(setf (var-loc var) var-loc))
(wt-nl) (wt-lex var-loc) (wt "=" loc ";")))
(wt-nl) (wt-lex var-loc) (wt "= ")
(wt-coerce-loc :object loc)
(wt ";")))
(wt-comment (var-name var))))
(SPECIAL
(bds-bind loc var))
(OBJECT
(if (eq (var-loc var) 'OBJECT)
;; set location for lambda list requireds
(setf (var-loc var) (second loc))
;; already has location (e.g. optional in lambda list)
(unless (and (consp loc) ; check they are not the same
(eq 'LCL (car loc))
(= (var-loc var) (second loc)))
(wt-nl) (wt-lcl (var-loc var)) (wt "= " loc ";"))
))
(t
(wt-nl) (wt-lcl (var-loc var)) (wt "= ")
(case (var-kind var)
(FIXNUM (wt-fixnum-loc loc))
(CHARACTER (wt-character-loc loc))
(LONG-FLOAT (wt-long-float-loc loc))
(SHORT-FLOAT (wt-short-float-loc loc))
(t (baboon)))
(wt ";")))
)
(cond ((not (eq (var-loc var) 'OBJECT))
;; already has location (e.g. optional in lambda list)
;; check they are not the same
(unless (equal (var-loc var) loc)
(wt-nl var "= ")
(wt-coerce-loc (var-rep-type var) loc)
(wt ";")))
((and (consp loc) (eql (car loc) 'LCL))
;; set location for lambda list requireds
(setf (var-loc var) loc))
(t
(error)))
)))
;;; Used by let*, defmacro and lambda's &aux, &optional, &rest, &keyword
(defun bind-init (var form)
@ -84,15 +81,16 @@
;; now the binding is in effect
(push 'BDS-BIND *unwind-exit*))))
(defun bds-bind (loc var &aux loc-var)
(defun bds-bind (loc var)
;; Optimize the case (let ((*special-var* *special-var*)) ...)
(if (and (consp loc)
(eq (car loc) 'var)
(typep (setq loc-var (second loc)) 'var)
(eq (var-kind loc-var) 'global)
(eq (var-name loc-var) (var-name var)))
(wt-nl "bds_push(" (var-loc var) ");")
(wt-nl "bds_bind(" (var-loc var) "," loc ");"))
(cond ((and (var-p loc)
(eq (var-kind loc) 'global)
(eq (var-name loc) (var-name var)))
(wt-nl "bds_push(" (var-loc var) ");"))
(t
(wt-nl "bds_bind(" (var-loc var) ",")
(wt-coerce-loc :object loc)
(wt ");")))
;; push BDS-BIND only once:
;; bds-bind may be called several times on the same variable, e.g.
;; an optional has two alternative bindings.

6
src/cmp/cmpblock.lsp
View file

@ -65,9 +65,9 @@
(blk-destination blk) *destination*)
(wt "{")
(unless (or (blk-ref-ccb blk) (blk-ref-clb blk))
(setf (var-loc blk-var) (next-lcl)
(var-kind blk-var) 'OBJECT)
(wt " cl_object ") (wt-var blk-var) (wt ";"))
(setf (var-kind blk-var) :object
(var-loc blk-var) (next-lcl))
(wt " cl_object " blk-var ";"))
(when (env-grows (blk-ref-ccb blk))
(let ((env-lvl *env-lvl*))
(wt-nl "volatile cl_object env" (incf *env-lvl*)

50
src/cmp/cmpcall.lsp
View file

@ -93,10 +93,10 @@
(unless loc
(cond ((eq (first form) 'LOCATION) (setq loc fun))
((and (eq (first form) 'VAR)
(not (var-changed-in-forms (first fun) args)))
(setq loc (cons 'VAR fun))) ; i.e. (VAR var)
(not (var-changed-in-forms fun args)))
(setq loc fun))
(t
(setq loc (list 'TEMP (next-temp)))
(setq loc (make-temp-var))
(let ((*destination* loc)) (c2expr* form)))))
(let ((*inline-blocks* 0))
@ -123,36 +123,37 @@
(*unwind-exit* *unwind-exit*))
(wt-nl "{ ")
(unless args-pushed
(setq narg `(LCL ,(next-lcl)))
(setq narg (make-lcl-var :type :cl-index))
(wt-nl "cl_index " narg "=0;"))
(when requireds
(wt-nl "cl_object ")
(let ((lcl (+ *lcl* nreq)))
(declare (fixnum lcl))
(do ((args requireds (cdr args)))
((null args))
(wt-lcl lcl) (when (cdr args) (wt ", ")) (decf lcl)))
(do ((l requireds (cdr l)))
((endp l))
(setf (var-loc (first l)) (next-lcl))
(unless (eq l requireds)
(wt ", "))
(wt (first l)))
(wt ";"))
(wt-nl "int narg;")
(wt-nl "cl_va_list args;")
(cond (args-pushed
(wt-nl "args[0].sp=cl_stack_index()-" narg ";")
(wt-nl "args[0].narg=" narg ";")
(dotimes (i nreq)
(wt-nl) (wt-lcl (next-lcl)) (wt "=cl_va_arg(args);")))
(dolist (l requireds)
(wt-nl l "=cl_va_arg(args);")))
(t
(dotimes (i nreq)
(let ((*destination* `(LCL ,(next-lcl))))
(dolist (l requireds)
(let ((*destination* l))
(c2expr* (pop args))))
(push (list STACK narg) *unwind-exit*)
(wt-nl "args[0].sp=cl_stack_index();")
(wt-nl "args[0].narg=" nopt ";")
(do* ((*inline-blocks* 0)
(vals (inline-args args) (cdr vals))
(vals (coerce-locs (inline-args args)) (cdr vals))
(i 0 (1+ i)))
((null vals) (close-inline-blocks))
(declare (fixnum i))
(wt-nl "cl_stack_push(" (second (first vals)) ");")
(wt-nl "cl_stack_push(" (first vals) ");")
(wt-nl narg "++;"))
(wt-nl "args[0].narg=" narg ";")))
(wt "narg=" narg ";")
@ -167,10 +168,10 @@
(when (or (eq args 'ARGS-PUSHED)
(< (length args) SI::C-ARGUMENTS-LIMIT))
(return-from maybe-push-args (values nil nil nil)))
(let* ((narg `(LCL ,(next-lcl))))
(let* ((narg (make-lcl-var :type :cl-index)))
(wt-nl "{cl_index " narg "=0;")
(let* ((*temp* *temp*)
(temp `(TEMP ,(next-temp)))
(temp (make-temp-var))
(*destination* temp))
(dolist (expr args)
(c2expr* expr)
@ -232,10 +233,7 @@
(let* ((*destination* 'TRASH)
(*exit* (next-label))
(*unwind-exit* (cons *exit* *unwind-exit*)))
(c2psetq
(mapcar #'(lambda (v) (list v)) ; nil (ccb)
(cdr *tail-recursion-info*))
args)
(c2psetq (cdr *tail-recursion-info*) args)
(wt-label *exit*)
(unwind-no-exit 'TAIL-RECURSION-MARK)
(wt-nl "goto TTL;")
@ -280,7 +278,7 @@
((and (not (eq 'ARGS-PUSHED locs))
(null loc)
(setq loc (inline-function fname locs return-type)))
(unwind-exit (fix-loc loc)))
(unwind-exit loc))
;; Call to a function defined in the same file.
((setq fd (assoc fname *global-funs* :test #'same-fname-p))
@ -327,11 +325,11 @@
(unless (and (inline-possible fun-name)
(or (and (symbolp fun-name) (get-sysprop fun-name 'Lfun))
(assoc fun-name *global-funs* :test #'same-fname-p)))
(let* ((temp (list 'TEMP (next-temp)))
(let* ((temp (make-temp-var))
(fdef (list 'FDEFINITION fun-name)))
(wt-nl temp "=" fdef ";")
temp))))
(ORDINARY (let* ((temp (list 'TEMP (next-temp)))
(ORDINARY (let* ((temp (make-temp-var))
(*destination* temp))
(c2expr* (third funob))
temp))
@ -344,7 +342,7 @@
;;;
(defun call-loc (fname fun args &optional narg-loc)
(cond ((not (eq 'ARGS-PUSHED args))
(list 'CALL fun (length args) (coerce-locs args nil) fname))
(list 'CALL fun (length args) (coerce-locs args) fname))
((stringp fun)
(list 'CALL "APPLY" narg-loc (list fun `(STACK-POINTER ,narg-loc))
fname))
@ -355,7 +353,7 @@
(cond ((not (eq 'ARGS-PUSHED args))
(when (/= (length args) maxarg)
(error "Too many arguments to function ~S." fname))
(list 'CALL-FIX fun (coerce-locs args nil) fname))
(list 'CALL-FIX fun (coerce-locs args) fname))
((stringp fun)
(wt "if(" narg-loc "!=" maxarg ") FEwrong_num_arguments_anonym();")
(list 'CALL-FIX "APPLY_fixed" (list fun `(STACK-POINTER ,narg-loc)) fname narg-loc))

10
src/cmp/cmpcatch.lsp
View file

@ -23,7 +23,7 @@
(defun c2catch (tag body)
(let* ((*lcl* *lcl*)
(tag-lcl (list 'LCL (next-lcl))))
(tag-lcl (make-lcl-var)))
(wt-nl "{ cl_object " tag-lcl ";")
(let* ((*destination* tag-lcl))
(c2expr* tag))
@ -48,7 +48,7 @@
(list 'UNWIND-PROTECT info form args)
)
(defun c2unwind-protect (form body &aux (nr (list 'LCL (next-lcl))))
(defun c2unwind-protect (form body)
(wt-nl "{ volatile bool unwinding = FALSE;")
(wt-nl "frame_ptr next_fr; cl_object next_tag;")
;; Here we compile the form which is protected. When this form
@ -63,7 +63,7 @@
;; Here we save the values of the form which might have been
;; aborted, and execute some cleanup code. This code may also
;; be aborted by some control structure, but is not protected.
(let* ((nr `(LCL ,(next-lcl)))
(let* ((nr (make-lcl-var :rep-type :cl-index))
(*unwind-exit* `((STACK ,nr) ,@*unwind-exit*))
(*destination* 'TRASH))
(wt-nl "{cl_index " nr "=cl_stack_push_values();")
@ -92,8 +92,8 @@
(defun c2throw (tag val &aux loc)
(case (car tag)
(LOCATION (setq loc (third tag)))
(VAR (setq loc (cons 'VAR (third tag))))
(t (setq loc (list 'TEMP (next-temp)))
(VAR (setq loc (third tag)))
(t (setq loc (make-temp-var))
(let ((*destination* loc)) (c2expr* tag))))
(let ((*destination* 'VALUES)) (c2expr* val))
(wt-nl "cl_throw(" loc ");"))

40
src/cmp/cmpdefs.lsp
View file

@ -13,20 +13,20 @@
(defpackage "C"
(:nicknames "COMPILER")
(:use "FFI" "CL")
(:export *compiler-break-enable*
*compile-print*
*compile-to-linking-call*
*compile-verbose*
*cc*
*cc-optimize*
build-ecl
build-program
build-static-library
build-shared-library
shared-library-pathname
static-library-pathname
*suppress-compiler-warnings*
*suppress-compiler-notes*)
(:export "*COMPILER-BREAK-ENABLE*"
"*COMPILE-PRINT*"
"*COMPILE-TO-LINKING-CALL*"
"*COMPILE-VERBOSE*"
"*CC*"
"*CC-OPTIMIZE*"
"BUILD-ECL"
"BUILD-PROGRAM"
"BUILD-STATIC-LIBRARY"
"BUILD-SHARED-LIBRARY"
"SHARED-LIBRARY-PATHNAME"
"STATIC-LIBRARY-PATHNAME"
"*SUPPRESS-COMPILER-WARNINGS*"
"*SUPPRESS-COMPILER-NOTES*")
(:import-from "SI" "GET-SYSPROP" "PUT-SYSPROP" "REM-SYSPROP"))
(in-package "COMPILER")
@ -50,8 +50,8 @@
;;; Number of references to the variable (-1 means IGNORE).
;;; During Pass 2: set below *register-min* for non register.
; ref-ccb ;;; Cross closure reference: T or NIL.
kind ;;; One of LEXICAL, SPECIAL, GLOBAL, OBJECT, FIXNUM,
;;; CHARACTER, LONG-FLOAT, SHORT-FLOAT, or REPLACED (used for
kind ;;; One of LEXICAL, SPECIAL, GLOBAL, :OBJECT, :FIXNUM,
;;; :CHAR, :DOUBLE, :FLOAT, or REPLACED (used for
;;; LET variables).
(loc 'OBJECT) ;;; During Pass 1: indicates whether the variable can
;;; be allocated on the c-stack: OBJECT means
@ -63,7 +63,7 @@
;;; OBJECT.
;;; During Pass 2:
;;; For REPLACED: the actual location of the variable.
;;; For FIXNUM, CHARACTER, LONG-FLOAT, SHORT-FLOAT, OBJECT:
;;; For :FIXNUM, :CHAR, :FLOAT, :DOUBLE, :OBJECT:
;;; the cvar for the C variable that holds the value.
;;; For LEXICAL: the frame-relative address for the variable.
;;; For SPECIAL and GLOBAL: the vv-index for variable name.
@ -246,7 +246,6 @@ The default value is NIL.")
;;; Compiled code uses the following kinds of variables:
;;; 1. Vi, declared explicitely, either unboxed or register (*lcl*, next-lcl)
;;; 2. Ti, declared collectively, of type object, may be reused (*temp*, next-temp)
;;; 3. Ui, declared collectively, of type unboxed (*unboxed*, next-unboxed)
;;; 4. lexi[j], for lexical variables in local functions
;;; 5. CLVi, for lexical variables in closures
@ -255,9 +254,6 @@ The default value is NIL.")
(defvar *temp* 0) ; number of temporary variables
(defvar *max-temp* 0) ; maximum *temp* reached
(defvar *unboxed*) ; list of unboxed variables
(defvar *next-unboxed* 0) ; number of *unboxed* used.
(defvar *level* 0) ; nesting level for local functions
(defvar *lex* 0) ; number of lexical variables in local functions
@ -290,7 +286,7 @@ The default value is NIL.")
;;; though &optional, &rest, and &key return types are simply ignored.
;;;
(defvar *function-declarations* nil)
(defvar *allow-c-local-declaration* nil)
(defvar *alien-declarations* nil)
(defvar *notinline* nil)

7
src/cmp/cmpenv.lsp
View file

@ -39,18 +39,13 @@
(setq *notinline* nil)
)
(defun next-lcl () (incf *lcl*))
(defun next-lcl () (list 'LCL (incf *lcl*)))
(defun next-temp ()
(prog1 *temp*
(incf *temp*)
(setq *max-temp* (max *temp* *max-temp*))))
(defun next-unboxed (type)
(let ((tem (incf *next-unboxed*)))
(push (list (rep-type type) tem) *unboxed*)
tem))
(defun next-lex ()
(prog1 (cons *level* *lex*)
(incf *lex*)

41
src/cmp/cmpeval.lsp
View file

@ -264,18 +264,18 @@
(defun c2structure-ref (form name-vv index
&aux (*inline-blocks* 0))
(let ((loc (second (car (inline-args (list form))))))
(let ((loc (first (coerce-locs (inline-args (list form))))))
(unwind-exit (list 'SYS:STRUCTURE-REF loc name-vv index)))
(close-inline-blocks)
)
(defun wt-structure-ref (loc name-vv index)
(if *safe-compile*
(wt "structure_ref(" loc "," name-vv "," index ")")
(wt "structure_ref(" loc "," name-vv "," `(COERCE-LOC :object ,index) ")")
#+clos
(wt "(" loc ")->instance.slots[" index "]")
(wt "(" loc ")->instance.slots[" `(COERCE-LOC :fixnum ,index) "]")
#-clos
(wt "(" loc ")->str.self[" index "]")))
(wt "(" loc ")->str.self[" `(COERCE-LOC :fixnum ,index) "]")))
(defun c1structure-set (args &aux (info (make-info)))
(if (and (not *safe-compile*) ; Beppe
@ -314,6 +314,7 @@
&aux locs (*inline-blocks* 0))
;; the third argument here *c1t* is just a hack to ensure that
;; a variable is introduced for y if it is an expression with side effects
(error)
(setq locs (inline-args (list x y *c1t*)))
(setq x (second (first locs)))
(setq y (second (second locs)))
@ -327,31 +328,6 @@
(close-inline-blocks)
)
;;; ----------------------------------------------------------------------
;;; Instances
#+clos
(defun c1instance-ref (args &aux (info (make-info)))
(let ((form (first args))
(index (second args)))
(if (sys::fixnump index)
(list 'SYS:INSTANCE-REF info (c1expr* form info) index)
(list 'CALL-GLOBAL info 'SYS:INSTANCE-REF (c1args args info)))))
#+clos
(defun c2instance-ref (form index
&aux (*inline-blocks* 0))
(let ((loc (second (car (inline-args (list form))))))
(unwind-exit (list 'SYS:INSTANCE-REF loc index)))
(close-inline-blocks)
)
#+clos
(defun wt-instance-ref (loc index)
(if *safe-compile*
(wt "instance_ref(" loc "," index ")")
(wt "(" loc ")->instance.slots[" index "]")))
;;; ----------------------------------------------------------------------
(defun c1constant-value (val always-p)
@ -406,10 +382,3 @@
(put-sysprop 'SYS:STRUCTURE-REF 'WT-LOC 'wt-structure-ref)
(put-sysprop 'SYS:STRUCTURE-SET 'C1 'c1structure-set)
(put-sysprop 'SYS:STRUCTURE-SET 'C2 'c2structure-set)
#+clos
(put-sysprop 'SYS:INSTANCE-REF 'C1 'c1instance-ref)
#+clos
(put-sysprop 'SYS:INSTANCE-REF 'C2 'c2instance-ref)
#+clos
(put-sysprop 'SYS:INSTANCE-REF 'WT-LOC 'wt-instance-ref)

213
src/cmp/cmpexit.lsp
View file

@ -19,7 +19,7 @@
(dolist (f (cdr stack-pop))
(wt "+" f))
(wt ");"))
(when bds-lcl (wt-nl "bds_unwind(") (wt-lcl bds-lcl) (wt ");"))
(when bds-lcl (wt-nl "bds_unwind(" bds-lcl ");"))
(dotimes (n bds-bind) (declare (fixnum n)) (wt-nl "bds_unwind1;")))
(defun unwind-exit (loc &optional (jump-p nil)
@ -33,136 +33,87 @@
(JUMP-FALSE
(set-jump-false loc (second *destination*))
(when (eq loc nil) (return-from unwind-exit)))))
(flet ((single-valued-call (loc)
(member (car loc)
'(INLINE INLINE-COND INLINE-FIXNUM
INLINE-CHARACTER INLINE-LONG-FLOAT INLINE-SHORT-FLOAT)
:test #'eq)))
(dolist (ue *unwind-exit* (baboon))
;; perform all unwind-exit's which precede *exit*
(cond
((consp ue) ; ( label# . ref-flag )| (STACK n)
(cond ((eq (car ue) 'STACK)
(push (second ue) stack-pop))
((eq ue *exit*)
;; all body forms except the last (returning) are dealt here
(cond ((and (consp *destination*)
(or (eq (car *destination*) 'JUMP-TRUE)
(eq (car *destination*) 'JUMP-FALSE)))
(unwind-bds bds-lcl bds-bind stack-pop))
((not (or bds-lcl (plusp bds-bind) stack-pop))
(set-loc loc))
;; Save the value if LOC may possibly refer
;; to special binding.
((and (consp loc)
(or (and (eq (car loc) 'VAR)
(member (var-kind (second loc))
'(SPECIAL GLOBAL)
:test #'eq))
(single-valued-call loc))
;; no need for temporary if we can use
;; *destination* directly
(consp *destination*)
(member (car *destination*) '(VAR BIND) :test #'eq))
(let* ((*temp* *temp*)
(temp (list 'TEMP (next-temp))))
(let ((*destination* temp))
(set-loc loc)) ; temp <- loc
(unwind-bds bds-lcl bds-bind stack-pop)
(set-loc temp))) ; *destination* <- temp
(t
(set-loc loc)
(unwind-bds bds-lcl bds-bind stack-pop)))
(when jump-p (wt-nl) (wt-go *exit*))
(return))
(t (setq jump-p t))))
((numberp ue) (setq bds-lcl ue
bds-bind 0))
(t (case ue
(BDS-BIND (incf bds-bind))
(RETURN
(unless (eq *exit* 'RETURN) (baboon))
;; *destination* must be either RETURN or TRASH.
(cond ((eq loc 'VALUES)
;; from multiple-value-prog1 or values
(unwind-bds bds-lcl bds-bind stack-pop)
(wt-nl "return VALUES(0);"))
((eq loc 'RETURN)
;; from multiple-value-prog1 or values
(unwind-bds bds-lcl bds-bind stack-pop)
(wt-nl "return value0;"))
(t
(let* ((*destination* 'RETURN))
(set-loc loc))
(unwind-bds bds-lcl bds-bind stack-pop)
(wt-nl "return value0;")))
(return))
(RETURN-FIXNUM
(when (eq *exit* ue)
;; *destination* must be RETURN-FIXNUM
(if (or bds-lcl (plusp bds-bind))
(let ((lcl (next-lcl)))
(wt-nl "{cl_fixnum ") (wt-lcl lcl) (wt "= ")
(wt-fixnum-loc loc) (wt ";")
(unwind-bds bds-lcl bds-bind stack-pop)
(wt-nl "return(") (wt-lcl lcl) (wt ");}"))
(progn
(wt-nl "return(") (wt-fixnum-loc loc) (wt ");")))
(return)))
(RETURN-CHARACTER
(when (eq *exit* ue)
;; *destination* must be RETURN-CHARACTER
(if (or bds-lcl (plusp bds-bind))
(let ((lcl (next-lcl)))
(wt-nl "{unsigned char ") (wt-lcl lcl) (wt "= ")
(wt-character-loc loc) (wt ";")
(unwind-bds bds-lcl bds-bind stack-pop)
(wt-nl "return(") (wt-lcl lcl) (wt ");}"))
(progn
(wt-nl "return(") (wt-character-loc loc) (wt ");")))
(return)))
(RETURN-LONG-FLOAT
(when (eq *exit* ue)
;; *destination* must be RETURN-LONG-FLOAT
(if (or bds-lcl (plusp bds-bind))
(let ((lcl (next-lcl)))
(wt-nl "{double ") (wt-lcl lcl) (wt "= ")
(wt-long-float-loc loc) (wt ";")
(unwind-bds bds-lcl bds-bind stack-pop)
(wt-nl "return(") (wt-lcl lcl) (wt ");}"))
(progn
(wt-nl "return(") (wt-long-float-loc loc) (wt ");")))
(return)))
(RETURN-SHORT-FLOAT
(when (eq *exit* ue)
;; *destination* must be RETURN-SHORT-FLOAT
(if (or bds-lcl (plusp bds-bind))
(let ((lcl (next-lcl)))
(wt-nl "{float ") (wt-lcl lcl) (wt "= ")
(wt-short-float-loc loc) (wt ";")
(unwind-bds bds-lcl bds-bind stack-pop)
(wt-nl "return(") (wt-lcl lcl) (wt ");}"))
(progn
(wt-nl "return(") (wt-short-float-loc loc) (wt ");")))
(return)))
(RETURN-OBJECT
(when (eq *exit* ue)
;; *destination* must be RETURN-OBJECT
(if (or bds-lcl (plusp bds-bind))
(progn
(wt-nl "{cl_object x =" loc ";")
(unwind-bds bds-lcl bds-bind stack-pop)
(wt-nl "return(x);}"))
(wt-nl "return(" loc ");"))
(return)))
(FRAME
(let ((*destination* 'RETURN))
(set-loc loc)
(setq loc *destination*))
(wt-nl "frs_pop();"))
(TAIL-RECURSION-MARK)
(JUMP (setq jump-p t))
(t (baboon)))))))
(dolist (ue *unwind-exit* (baboon))
;; perform all unwind-exit's which precede *exit*
(cond
((consp ue) ; ( label# . ref-flag )| (STACK n) |(LCL n)
(cond ((eq (car ue) 'STACK)
(push (second ue) stack-pop))
((eq (car ue) 'LCL)
(setq bds-lcl ue bds-bind 0))
((eq ue *exit*)
;; all body forms except the last (returning) are dealt here
(cond ((and (consp *destination*)
(or (eq (car *destination*) 'JUMP-TRUE)
(eq (car *destination*) 'JUMP-FALSE)))
(unwind-bds bds-lcl bds-bind stack-pop))
((not (or bds-lcl (plusp bds-bind) stack-pop))
(set-loc loc))
;; Save the value if LOC may possibly refer
;; to special binding.
((or (loc-refers-to-special loc)
(loc-refers-to-special *destination*))
(let* ((*temp* *temp*)
(temp (make-temp-var)))
(let ((*destination* temp))
(set-loc loc)) ; temp <- loc
(unwind-bds bds-lcl bds-bind stack-pop)
(set-loc temp))) ; *destination* <- temp
(t
(set-loc loc)
(unwind-bds bds-lcl bds-bind stack-pop)))
(when jump-p (wt-nl) (wt-go *exit*))
(return))
(t (setq jump-p t))))
((numberp ue) (error)
(setq bds-lcl ue bds-bind 0))
(t (case ue
(BDS-BIND (incf bds-bind))
(RETURN
(unless (eq *exit* 'RETURN) (baboon))
;; *destination* must be either RETURN or TRASH.
(cond ((eq loc 'VALUES)
;; from multiple-value-prog1 or values
(unwind-bds bds-lcl bds-bind stack-pop)
(wt-nl "return VALUES(0);"))
((eq loc 'RETURN)
;; from multiple-value-prog1 or values
(unwind-bds bds-lcl bds-bind stack-pop)
(wt-nl "return value0;"))
(t
(let* ((*destination* 'RETURN))
(set-loc loc))
(unwind-bds bds-lcl bds-bind stack-pop)
(wt-nl "return value0;")))
(return))
((RETURN-FIXNUM RETURN-CHARACTER RETURN-LONG-FLOAT
RETURN-SHORT-FLOAT RETURN-OBJECT)
(when (eq *exit* ue)
;; *destination* must be RETURN-FIXNUM
(setq loc (list 'COERCE-LOC
(getf '(RETURN-FIXNUM :fixnum
RETURN-CHARACTER :char
RETURN-LONG-FLOAT :float
RETURN-DOUBLE-FLOAT :double
RETURN-OBJECT :object)
ue)
loc))
(if (or bds-lcl (plusp bds-bind))
(let ((lcl (make-lcl-var :type (second loc))))
(wt-nl "{cl_fixnum " lcl "= " loc ";")
(unwind-bds bds-lcl bds-bind stack-pop)
(wt-nl "return(" lcl ");}"))
(progn
(wt-nl "return(" loc ");")))
(return)))
(FRAME
(let ((*destination* 'RETURN))
(set-loc loc)
(setq loc *destination*))
(wt-nl "frs_pop();"))
(TAIL-RECURSION-MARK)
(JUMP (setq jump-p t))
(t (baboon))))))
;;; Never reached
)

343
src/cmp/cmpffi.lsp Normal file
View file

@ -0,0 +1,343 @@
;;;; CMPFFI -- Foreign functions interface.
;;;; Copyright (c) 2003, Juan Jose Garcia-Ripoll.
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
(in-package "COMPILER")
;; ----------------------------------------------------------------------
;; REPRESENTATION TYPES
;;
(defconstant +representation-types+
'(:byte ((signed-byte 8) "byte")
:unsigned-byte ((unsigned-byte 8) "unsigned byte")
:fixnum (fixnum "cl_fixnum")
:int ((signed-byte 32) "int")
:unsigned-int ((unsigned-byte 32) "unsigned int")
:long ((signed-byte 32) "long")
:unsigned-long ((unsigned-byte 32) "unsigned long")
:cl-index ((integer 0 #.most-positive-fixnum) "cl_index")
:float (short-float "float")
:double (long-float "double")
:char (character "char")
:unsigned-char (character "char")
:void (nil "void")
:object (t "cl_object")
:bool (t "bool")))
(defun rep-type->lisp-type (rep-type)
(let ((output (getf +representation-types+ rep-type)))
(cond (output (first output))
((lisp-type-p rep-type) rep-type)
(t (error "Unknown representation type ~S" rep-type)))))
(defun lisp-type->rep-type (type)
(if (getf +representation-types+ type)
type
(do ((l +representation-types+ (cddr l)))
((endp l) :object)
(when (subtypep type (first (second l)))
(return-from lisp-type->rep-type (first l))))))
(defun rep-type-name (type)
(or (second (getf +representation-types+ type))
(error "Unknown type name ~S found in compiled expression" type)))
(defun lisp-type-p (type)
(subtypep type 'T))
;; ----------------------------------------------------------------------
;; LOCATIONS and representation types
;;
;; Locations are lisp expressions which represent actual C data. To each
;; location we can associate a representation type, which is the type of
;; the C data. The following routines help in determining these types,
;; and also in moving data from one location to another.
(defun loc-movable-p (loc)
(if (atom loc)
t
(case (first loc)
((CALL CALL-LOCAL) NIL)
((C-INLINE) (not (fifth loc))) ; side effects?
(otherwise t))))
(defun loc-type (loc)
(cond ((eq loc NIL) 'NULL)
((var-p loc) (var-type loc))
((atom loc) 'T)
(t
(case (first loc)
(FIXNUM-VALUE 'FIXNUM)
(CHARACTER-VALUE 'CHARACTER)
(LONG-FLOAT-VALUE 'LONG-FLOAT)
(SHORT-FLOAT-VALUE 'SHORT-FLOAT)
(C-INLINE (rep-type->lisp-type (second loc)))
(BIND (var-type (second loc)))
(otherwise T)))))
(defun loc-representation-type (loc)
(cond ((eq loc NIL) :object)
((var-p loc) (var-rep-type loc))
((atom loc) :object)
(t
(case (first loc)
(FIXNUM-VALUE :fixnum)
(CHARACTER-VALUE :char)
(LONG-FLOAT-VALUE :double)
(SHORT-FLOAT-VALUE :float)
(C-INLINE (second loc))
(BIND (var-rep-type (second loc)))
(otherwise :object)))))
(defun wt-coerce-loc (dest-rep-type loc)
(setq dest-rep-type (lisp-type->rep-type dest-rep-type))
;(print dest-rep-type)
;(print loc)
(let* ((dest-type (rep-type->lisp-type dest-rep-type))
(loc-type (loc-type loc))
(loc-rep-type (loc-representation-type loc)))
(labels ((coercion-error ()
(cmperr "Unable to coerce lisp object from type (~S,~S)~%~
to C/C++ type (~S,~S)"
loc-type loc-rep-type dest-type dest-rep-type))
(ensure-valid-object-type (a-lisp-type)
(when (subtypep `(AND ,loc-type ,a-lisp-type) NIL)
(coercion-error))))
(when (eq dest-rep-type loc-rep-type)
(wt loc)
(return-from wt-coerce-loc))
(case dest-rep-type
((:int :unsigned-int :long :unsigned-long :byte :unsigned-byte :fixnum)
(case loc-rep-type
((:int :unsigned-int :long :unsigned-long :byte :unsigned-byte :fixnum
:float :double)
(wt "((" (rep-type-name dest-rep-type) ")" loc ")"))
((:object)
(ensure-valid-object-type dest-type)
(wt (if (subtypep (loc-type loc) 'fixnum) "fix(" "object_to_fixnum(")
loc ")"))
(otherwise
(coercion-error))))
((:char :unsigned-char)
(case loc-rep-type
((:char :unsigned-char)
(wt "((" (rep-type-name dest-rep-type) ")" loc ")"))
((:object)
(ensure-valid-object-type dest-type)
(wt "char_code(" loc ")"))
(otherwise
(coercion-error))))
((:float :double)
(case loc-rep-type
((:int :unsigned-int :long :unsigned-long :byte :unsigned-byte :fixnum
:float :double)
(wt "((" (rep-type-name dest-rep-type) ")" loc ")"))
((:object)
;; We relax the check a bit, because it is valid in C to coerce
;; between floats of different types.
(ensure-valid-object-type 'FLOAT)
(wt (if (eq loc-rep-type :float) "object_to_float(" "object_to_double(")
loc ")"))
(otherwise
(coercion-error))))
((:bool)
(case loc-rep-type
((:int :unsigned-int :long :unsigned-long :byte :unsigned-byte :fixnum
:float :double :char :unsigned-char)
(wt "1"))
((:object)
(wt "(" loc ")!=Cnil"))
(otherwise
(coercion-error))))
((:object)
(case loc-rep-type
((:int :unsigned-int :long :unsigned-long)
(wt "make_integer(" loc ")"))
((:byte :unsigned-byte :fixnum)
(wt "MAKE_FIXNUM(" loc ")"))
((:float)
(if (and (consp loc) (eq (first loc) 'SHORT-FLOAT-VALUE))
(wt (third loc)) ;; VV index
(wt "make_shortfloat(" loc ")")))
((:double)
(if (and (consp loc) (eq (first loc) 'LONG-FLOAT-VALUE))
(wt (third loc)) ;; VV index
(wt "make_longfloat(" loc ")")))
((:bool)
(wt "((" loc ")?Ct:Cnil)"))
((:char :unsigned-char)
(wt "CODE_CHAR(" loc ")"))
(otherwise
(coercion-error))))
(t
(coercion-error))))))
;; ----------------------------------------------------------------------
;; C/C++ INLINE CODE
;;
(defun c1c-inline (args)
(destructuring-bind (arguments arg-types output-type c-expression
&key side-effects one-liner
&aux output-rep-type)
args
(if (lisp-type-p output-type)
(setq output-rep-type (lisp-type->rep-type output-type))
(setq output-rep-type output-type
output-type (rep-type->lisp-type output-type)))
(let* ((info (make-info :type output-type))
(processed-arguments '()))
(unless (and (listp arguments)
(listp arg-types)
(stringp c-expression))
(cmperr "C-INLINE: wrong type of arguments ~S"
arguments arg-types c-expression))
(do ((processed-arguments '())
(processed-arg-types '()))
((and (endp arguments) (endp arg-types))
(list 'C-INLINE info
(nreverse processed-arguments)
(nreverse processed-arg-types)
output-rep-type
c-expression
side-effects
one-liner))
(push (or (pop arg-types) 'T) processed-arg-types)
(push (c1expr* (pop arguments) info) processed-arguments)))))
(defun produce-inline-loc (inlined-arguments arg-types output-rep-type
c-expression side-effects one-liner)
(let* (args-to-be-saved
coerced-arguments)
(when (and (> (length c-expression) 1)
(eq (char c-expression 0) #\@))
(do ((ndx 1 (1+ ndx)))
((or (>= ndx (length c-expression))
(eq (char c-expression ndx) #\;)))
(push (- (char-code (char c-expression ndx)) (char-code #\0))
args-to-be-saved)))
(setf coerced-arguments (coerce-locs inlined-arguments arg-types args-to-be-saved))
(setf output-rep-type (lisp-type->rep-type output-rep-type))
;; If the form does not output any data, and there are no side
;; effects, try to omit it.
(cond ((eq output-rep-type :void)
(if side-effects
(wt-c-inline-loc output-rep-type c-expression coerced-arguments t nil)
(cmpwarn "Ignoring form ~S" c-expression))
NIL)
(one-liner
`(C-INLINE ,output-rep-type ,c-expression ,coerced-arguments ,side-effects NIL))
(t
(let ((output-var (make-lcl-var :rep-type output-rep-type)))
(incf *inline-blocks*)
(wt-nl "{" (rep-type-name output-rep-type) " " output-var ";")
(wt-c-inline-loc output-rep-type c-expression coerced-arguments side-effects output-var)
output-var)))))
(defun c2c-inline (arguments &rest rest)
(let ((*inline-blocks* 0))
(unwind-exit (apply #'produce-inline-loc (inline-args arguments) rest))
(close-inline-blocks)))
(defun coerce-locs (inlined-args &optional types args-to-be-saved)
(do* ((l inlined-args (cdr l))
(item (first l) (first l))
(i 0 (1+ i))
(block-opened nil))
((endp l)
inlined-args)
(let* ((type (if types (pop types) :object))
(rep-type (lisp-type->rep-type type))
(expected-arg-type (rep-type->lisp-type type))
(lisp-type (first item))
(loc (second item)))
; (unless (and (eql rep-type (loc-representation-type loc))
; (or (loc-movable-p loc)
; (not (member i args-to-be-saved))))
(cond ((and (not (loc-movable-p loc)) (member i args-to-be-saved))
(let ((lcl (make-lcl-var :rep-type rep-type)))
(wt-nl)
(unless block-opened
(incf *inline-blocks*)
(wt-nl "{"))
(wt (rep-type-name rep-type) " " lcl "= ")
(wt-coerce-loc rep-type loc)
(wt ";")
(setq loc lcl)))
((and (not (equal rep-type (loc-representation-type loc))))
(setq loc `(COERCE-LOC ,rep-type ,loc))))
(setf (first l) loc)
)))
(defun wt-c-inline-loc (output-rep-type c-expression coerced-arguments side-effects output-var)
(with-input-from-string (s c-expression
:start
(if (eq (char c-expression 0) #\@)
(1+ (or (position #\; c-expression)
-1))
0))
(when output-var
(wt-nl))
(do ((c (read-char s nil nil)
(read-char s nil nil)))
((null c))
(case c
(#\@
(let ((object (read s)))
(cond ((equal object '(RETURN))
(if output-var
(wt output-var)
(cmperr "Tried to use @RETURN within a one-line C-INLINE form")))
(t
(when (and (consp object) (eq (first object) 'QUOTE))
(setq object (second object)))
(wt (add-object object))))))
(#\#
(let* ((k (char-downcase (read-char s)))
(index (- (char-code k)
(char-code (if (char<= #\0 k #\9) #\0 #\a)))))
(when (or (< index 0) (>= index (length coerced-arguments)))
(cmperr "C-INLINE: Variable code exceeds number of arguments"))
(wt (nth index coerced-arguments))))
(otherwise
(write-char c *compiler-output1*))))))
;; ----------------------------------------------------------------------
;; SIMPLIFIED INTERFACES TO C-INLINE
;;
(defmacro defentry (lisp-name c-types c-name)
(let ((out-type (if (consp c-name) (first c-name) :object))
(arg-names (mapcar #'(lambda (x) (gensym)) c-types)))
(when (consp c-name)
(setq c-name (second c-name)))
(cond ((symbolp c-name)
(setq c-name (string-downcase (symbol-name c-name))))
((not (stringp c-name))
(error "~S is not a valid C/C++ function name" c-name)))
`(defun ,lisp-name ,arg-names
(c-inline ,arg-names ,c-types ,out-type
,(with-output-to-string (s)
(format s "~a(" c-name)
(do ((l c-types (cdr l))
(i 0 (1+ i)))
((endp l) (princ #\) s))
(format s "#~d~:[~;,~]" i (cdr l))))
:one-liner t))))
(put-sysprop 'C-INLINE 'C1SPECIAL #'c1c-inline)
(put-sysprop 'C-INLINE 'C2 #'c2c-inline)
(put-sysprop 'C-INLINE 'WT-LOC #'wt-c-inline-loc)
(put-sysprop 'COERCE-LOC 'WT-LOC #'wt-coerce-loc)

11
src/cmp/cmpflet.lsp
View file

@ -109,7 +109,7 @@
(setf (var-loc var) (next-lcl))
(unless block-p
(setq block-p t) (wt-nl "{ "))
(wt "cl_object ") (wt-lcl (var-loc var)) (wt ";"))
(wt "cl_object " var ";"))
(unless env-grows
(setq env-grows (var-ref-ccb var))))))
;; or in closure environment:
@ -270,7 +270,7 @@
;; we introduce a variable to hold the funob
(let ((var (or (fun-var fun)
(setf (fun-var fun)
(make-var :name fname :kind 'OBJECT)))))
(make-var :name fname :kind :OBJECT)))))
(cond (ccb (setf (var-ref-ccb var) t
(var-kind var) 'LEXICAL)
(setf (fun-ref-ccb fun) t))
@ -318,10 +318,7 @@
(let* ((*destination* 'TRASH)
(*exit* (next-label))
(*unwind-exit* (cons *exit* *unwind-exit*)))
(c2psetq
(mapcar #'(lambda (v) (list v)) ; nil (ccb)
(cdr *tail-recursion-info*))
args)
(c2psetq (cdr *tail-recursion-info*) args)
(wt-label *exit*))
(unwind-no-exit 'TAIL-RECURSION-MARK)
(wt-nl "goto TTL;")
@ -337,7 +334,7 @@
(list 'CALL-LOCAL "APPLY" lex-level closure-p
(list fun `(STACK-POINTER ,narg)) narg fname)
(list 'CALL-LOCAL fun lex-level closure-p
(coerce-locs (inline-args args) nil) narg fname)))
(coerce-locs (inline-args args)) narg fname)))
(close-inline-blocks)))))
(defun wt-call-local (fun lex-lvl closure-p args narg fname)

178
src/cmp/cmpfun.lsp
View file

@ -26,27 +26,18 @@
(<= (length (car args)) *princ-string-limit*))
(characterp (car args)))
(or (endp (cdr args))
(and (eq (car stream) 'VAR)
(member (var-kind (car (third stream)))
'(GLOBAL SPECIAL) :test #'eq))))
(list 'PRINC info (car args)
(if (endp (cdr args)) nil (var-loc (caaddr stream)))
(eq (car stream) 'VAR)))
(list 'C2PRINC info (car args) (if (endp (cdr args)) nil (third stream))
stream)
(list 'CALL-GLOBAL info 'PRINC
(list (c1expr* (car args) info) stream))))
(list 'CALL-GLOBAL info 'PRINC (list (c1expr* (car args) info) stream))))
(defun c2princ (string vv-index stream)
(defun c2princ (string stream-var stream)
(cond ((eq *destination* 'TRASH)
(cond ((characterp string)
(wt-nl "princ_char(" (char-code string))
(if (null vv-index) (wt ",Cnil")
(wt ",symbol_value(" vv-index ")"))
(wt ");"))
(wt-nl "princ_char(" (char-code string) "," stream-var ");"))
((= (length string) 1)
(wt-nl "princ_char(" (char-code (aref string 0)))
(if (null vv-index) (wt ",Cnil")
(wt ",symbol_value(" vv-index ")"))
(wt ");"))
(wt-nl "princ_char(" (char-code (aref string 0)) ","
stream-var ");"))
(t
(wt-nl "princ_str(\"")
(dotimes (n (length string))
@ -56,10 +47,7 @@
((char= char #\") (wt "\\\""))
((char= char #\Newline) (wt "\\n"))
(t (wt char)))))
(wt "\",")
(if (null vv-index) (wt "Cnil")
(wt "symbol_value(" vv-index ")"))
(wt ");")))
(wt "\"," stream-var ");")))
(unwind-exit nil))
((eql string #\Newline) (c2call-global 'TERPRI (list stream) nil t))
(t (c2call-global
@ -77,10 +65,9 @@
(c1expr* (car args) info)))
(if (or (endp args)
(and (eq (car stream) 'VAR)
(member (var-kind (car (third stream)))
'(GLOBAL SPECIAL) :test #'eq)))
(list 'PRINC info #\Newline
(if (endp args) nil (var-loc (caaddr stream)))
(member (var-kind (third stream)) '(GLOBAL SPECIAL))))
(list 'C2PRINC info #\Newline
(if (endp args) nil (third stream))
stream)
(list 'CALL-GLOBAL info 'TERPRI (list stream))))
@ -111,18 +98,18 @@
(defun c2apply-lambda/local (funob args)
(let* ((loc (save-funob funob))
(temp *temp*)
(*temp* temp) ; allow reuse of TEMP variables
(arg (list 'TEMP 0))
(narg (list 'LCL (next-lcl)))
(*temp* *temp*)
(temp-args '())
(narg (make-lcl-var :rep-type :cl-index))
(is-lambda (eq 'LAMBDA (first funob))))
;; We must prepare in the lisp stack the following:
;; lex0, ..., lexk, env, arg1, ..., argn
(wt-nl "{ cl_index " narg ";")
(dolist (expr args)
(setf (second arg) (next-temp))
(let ((*destination* arg)) (c2expr* expr)))
(setf (second arg) temp) ; restart numbering
(let ((*destination* (make-temp-var)))
(push *destination* temp-args)
(c2expr* expr)))
(setf temp-args (nreverse temp-args))
(unless is-lambda
(let* ((fun (third funob))
(lex-lvl (fun-level fun))
@ -133,9 +120,9 @@
;; env of local fun is ALWAYS contained in current env (?)
(wt-nl "cl_stack_push((cl_object)env" *env-lvl* ");"))))
(dotimes (i (1- (length args)))
(wt-nl "cl_stack_push(" arg ");")
(incf (second arg)))
(wt-nl narg "=" (1- (length args)) "+cl_stack_push_list(" arg ");")
(wt-nl "cl_stack_push(" (pop temp-args) ");"))
(wt-nl narg "=" (1- (length args))
"+cl_stack_push_list(" (pop temp-args) ");")
(let ((*unwind-exit* `((STACK ,narg) ,@*unwind-exit*)))
(if is-lambda
(c2funcall funob 'ARGS-PUSHED loc narg)
@ -157,7 +144,7 @@
(list 'LET info (nreverse vl) (nreverse fl) body))
(t
(let ((*vars* *vars*)
(temp (or rest (make-var :name (gensym) :kind 'OBJECT
(temp (or rest (make-var :name (gensym) :kind :OBJECT
:ref (length args)))))
(push-vars temp)
(push temp vl)
@ -180,9 +167,9 @@
(list 'RPLACA info args))
(defun c2rplaca (args &aux (*inline-blocks* 0) x y)
(setq args (inline-args args)
x (second (first args))
y (second (second args)))
(setq args (coerce-locs (inline-args args))
x (first args)
y (second args))
(safe-compile
(wt-nl "if(ATOM(" x "))"
"FEtype_error_cons(" x ");"))
@ -199,9 +186,9 @@
(list 'RPLACD info args))
(defun c2rplacd (args &aux (*inline-blocks* 0) x y)
(setq args (inline-args args)
x (second (first args))
y (second (second args)))
(setq args (coerce-locs (inline-args args))
x (first args)
y (second args))
(safe-compile
(wt-nl "if(ATOM(" x "))"
"FEtype_error_cons(" x ");"))
@ -225,13 +212,14 @@
(defun c2member!2 (fun args
&aux (*inline-blocks* 0))
(setq args (coerce-locs (inline-args args) nil))
(unwind-exit
(list 'INLINE nil
(produce-inline-loc (inline-args args) '(T T) :object
(case fun
(EQ "si_memq(#0,#1)")
(EQL "memql(#0,#1)")
(EQUAL "member(#0,#1)")) args))
(EQUAL "member(#0,#1)"))
nil ; side effects?
t)) ; one liner?
(close-inline-blocks))
(defun c1assoc (args &aux (info (make-info)))
@ -251,14 +239,16 @@
(defun c2assoc!2 (fun args
&aux (*inline-blocks* 0))
(setq args (coerce-locs (inline-args args) nil))
(unwind-exit
(list 'INLINE nil
(produce-inline-loc (inline-args args) '(T T) :object
(case fun
(eq "assq(#0,#1)")
(eql "assql(#0,#1)")
(equal "assoc(#0,#1)")
(equalp "assqlp(#0,#1)")) args)) ;Beppe
(equalp "assqlp(#0,#1)"))
nil ; side effects?
t
))
(close-inline-blocks))
(defun co1nth (args)
@ -308,7 +298,7 @@
(defun c2rplaca-nthcdr-immediate (index args
&aux (*inline-blocks* 0))
(declare (fixnum index))
(setq args (coerce-locs (inline-args args) nil))
(setq args (coerce-locs (inline-args args)))
(if *safe-compile*
(progn
(wt-nl "{cl_object l= ")
@ -338,19 +328,19 @@
(c1args (list (second args)) info))
(list 'CALL-GLOBAL info 'SYS:LIST-NTH (c1args args info))))
(defun c2list-nth-immediate (index args &aux (l (next-lcl))
(defun c2list-nth-immediate (index args &aux (l (make-lcl-var))
(*inline-blocks* 0))
(declare (fixnum index))
(setq args (coerce-locs (inline-args args) nil))
(wt-nl "{cl_object ") (wt-lcl l) (wt "= ")
(setq args (coerce-locs (inline-args args)))
(wt-nl "{cl_object " l "= ")
(if *safe-compile*
(progn
(dotimes (i index) (declare (fixnum i)) (wt "cl_cdr("))
(wt (car args))
(dotimes (i index) (declare (fixnum i)) (wt ")"))
(wt ";")
(wt-nl "if(ATOM(") (wt-lcl l) (wt "))")
(wt-nl " FEtype_error_cons(") (wt-lcl l) (wt ");")
(wt-nl "if(ATOM(" l "))")
(wt-nl " FEtype_error_cons(" l ");")
)
(progn
(dotimes (i index) (declare (fixnum i)) (wt "CDR("))
@ -392,43 +382,35 @@
(endp (cdddr args))
(let ((op-code (first args))
(info (make-info))
c1args)
c1args string)
(and (constantp op-code)
(sys:fixnump (setq op-code (eval op-code)))
(setq c1args (c1args (cons op-code (rest args)) info))
(setq c1args (c1args (rest args) info))
(eq 'FIXNUM (info-type (second (second c1args))))
(eq 'FIXNUM (info-type (second (third c1args))))
`(BOOLE ,info ,c1args)))))
`(C-INLINE ,c1args (T T) FIXNUM
,(boole-inline-string op-code)
:side-effects nil
:one-liner t)))))
(defun c2boole (args)
(flet ((coerce-to-fixnums (locs)
(do ((l locs (cdr l)))
((null l) locs)
(unless (eq 'FIXNUM (caar l))
(setf (caar l) 'fixnum-loc)))))
(let* ((boole-op-arg (third (first args)))
(string (ecase (second boole-op-arg)
(#. boole-clr "(0)")
(#. boole-set "(1)")
(#. boole-1 "(#0)")
(#. boole-2 "(#1)")
(#. boole-c1 "(~(#0))")
(#. boole-c2 "(~(#1))")
(#. boole-and "((#0) & (#1))")
(#. boole-ior "((#0) | (#1))")
(#. boole-xor "((#0) ^ (#1))")
(#. boole-eqv "(~((#0) ^ (#1)))")
(#. boole-nand "(~((#0) & (#1)))")
(#. boole-nor "(~((#0)|(#1)))")
(#. boole-andc1 "((~(#0))&(#1))")
(#. boole-andc2 "(((#0))&(~(#1)))")
(#. boole-orc1 "(~(#0) | (#1))")
(#. boole-orc2 "((#0) | (~(#1)))"))))
(let ((*inline-blocks* 0))
(unwind-exit
(list 'INLINE-FIXNUM nil string
(coerce-to-fixnums (inline-args (rest args)))))
(close-inline-blocks)))))
(defun boole-inline-string (op-code)
(ecase op-code
(#. boole-clr "(0)")
(#. boole-set "(1)")
(#. boole-1 "(#0)")
(#. boole-2 "(#1)")
(#. boole-c1 "(~(#0))")
(#. boole-c2 "(~(#1))")
(#. boole-and "((#0) & (#1))")
(#. boole-ior "((#0) | (#1))")
(#. boole-xor "((#0) ^ (#1))")
(#. boole-eqv "(~((#0) ^ (#1)))")
(#. boole-nand "(~((#0) & (#1)))")
(#. boole-nor "(~((#0)|(#1)))")
(#. boole-andc1 "((~(#0))&(#1))")
(#. boole-andc2 "(((#0))&(~(#1)))")
(#. boole-orc1 "(~(#0) | (#1))")
(#. boole-orc2 "((#0) | (~(#1)))")))
;----------------------------------------------------------------------
@ -474,29 +456,6 @@
(type-filter (second x)))
(t t)))
(defun co1eql (args)
(when (and (cdr args)
(not *safe-compile*)
(flet ((replace-constant (lis)
(do ((v lis (cdr v))
(found) (tem))
((null v) found)
(when (and (constantp (car v))
(or (numberp (setq tem (eval (car v))))
(characterp tem)))
(setq found t) (setf (car v) tem)))))
(replace-constant args)))
(when (characterp (second args))
(setq args (reverse args)))
(when (characterp (car args))
(let ((c (gensym)))
(c1expr
`(let ((,c ,(second args)))
(declare (type ,(result-type (second args)) ,c))
(and (characterp ,c)
(= (char-code ,(car args))
(the fixnum (char-code (the character ,c)))))))))))
;----------------------------------------------------------------------
(defun co1ldb (args &aux (arg1 (first args))
@ -541,7 +500,7 @@
;;; ----------------------------------------------------------------------
(put-sysprop 'princ 'C1 'c1princ)
(put-sysprop 'princ 'C2 'c2princ)
(put-sysprop 'c2princ 'C2 'c2princ)
(put-sysprop 'terpri 'C1 'c1terpri)
(put-sysprop 'apply 'C1 'c1apply)
@ -569,7 +528,6 @@
(put-sysprop 'boole 'C1CONDITIONAL 'co1boole)
(put-sysprop 'coerce 'C1CONDITIONAL 'co1coerce)
(put-sysprop 'cons 'C1CONDITIONAL 'co1cons)
(put-sysprop 'eql 'C1CONDITIONAL 'co1eql)
(put-sysprop 'ldb 'C1CONDITIONAL 'co1ldb)
(put-sysprop 'vector-push 'C1CONDITIONAL 'co1vector-push)
(put-sysprop 'vector-push-extend 'C1CONDITIONAL 'co1vector-push-extend)

136
src/cmp/cmpif.lsp
View file

@ -190,9 +190,7 @@
(unwind-exit nil 'JUMP) (wt "}")
)))
((eq (car form) 'VAR)
(wt-nl "if(")
(wt-var (car (third form))) ; (second (third form)) ccb
(wt "==Cnil){")
(wt-nl "if(" (third form) "==Cnil){")
(unwind-exit nil 'JUMP) (wt "}"))
(t
(let* ((label (next-label))
@ -223,10 +221,8 @@
(t (wt-nl "if(" (third form) "!=Cnil){")
(unwind-exit (third form) 'JUMP) (wt "}"))))
((eq (car form) 'VAR)
(wt-nl "if(")
(wt-var (car (third form))) ; (second (third form)) ccb
(wt "!=Cnil){")
(unwind-exit (cons 'VAR (third form)) 'JUMP) (wt "}"))
(wt-nl "if(" (third form) "!=Cnil){")
(unwind-exit (third form) 'JUMP) (wt "}"))
((and (eq (car form) 'CALL-GLOBAL)
(get-sysprop (third form) 'PREDICATE))
(let* ((label (next-label))
@ -248,102 +244,36 @@
)
(defun set-jump-true (loc label)
(unless (null loc)
(cond ((eq loc t))
((atom loc)
(wt-nl "if((" loc ")!=Cnil)"))
((eq (car loc) 'INLINE-COND)
(wt-nl "if(")
(wt-inline-loc (third loc) (fourth loc))
(wt ")"))
;; Get calls inside conditional
(t (wt-nl "if((" loc ")!=Cnil)")))
(unless (eq loc t) (wt "{"))
(unwind-no-exit label)
(wt-nl) (wt-go label)
(unless (eq loc t) (wt "}")))
)
(cond ((null loc))
((eq loc t)
(unwind-no-exit label)
(wt-nl) (wt-go label))
(t
(cond ((eq (loc-representation-type loc) :bool)
(wt-nl "if(" loc "){"))
(t
(wt-nl "if((")
(wt-coerce-loc :object loc)
(wt ")!=Cnil){")))
(unwind-no-exit label)
(wt-nl) (wt-go label)
(wt "}"))))
(defun set-jump-false (loc label)
(unless (eq loc t)
(cond ((null loc))
((atom loc)
(wt-nl "if((" loc ")==Cnil)"))
((eq (car loc) 'INLINE-COND)
(wt-nl "if(!(")
(wt-inline-loc (third loc) (fourth loc))
(wt "))"))
(t (wt-nl "if((" loc ")==Cnil)")))
(unless (null loc) (wt "{"))
(unwind-no-exit label)
(wt-nl) (wt-go label)
(unless (null loc) (wt "}")))
)
(defun c1ecase (args) (c1case args t))
(defun c1case (args &optional (default nil))
(when (endp args) (too-few-args 'case 1 0))
(let* ((info (make-info))
(key-form (c1expr* (car args) info))
(clauses nil))
(dolist (clause (cdr args))
(cmpck (endp clause) "The CASE clause ~S is illegal." clause)
(case (car clause)
((NIL))
((T OTHERWISE)
(when default
(cmperr (if (eq default 't)
"ECASE had an OTHERWISE clause."
"CASE had more than one OTHERWISE clauses.")))
(setq default (c1progn (cdr clause)))
(add-info info (second default)))
(t (let* ((rawkeylist (car clause))
(keylist
(if (consp rawkeylist)
(mapcar #'(lambda (key) (c1constant-value key t))
rawkeylist)
(list (c1constant-value rawkeylist t))))
(body (c1progn (cdr clause))))
(add-info info (second body))
(push (cons keylist body) clauses)))))
(list 'CASE info key-form (nreverse clauses) (or default (c1nil)))))
(defun c2case (key-form clauses default
&aux loc (*inline-blocks* 0))
(setq key-form (second (first (inline-args (list key-form)))))
(if (and (consp key-form) (eq (car key-form) 'VAR))
(setq loc key-form)
(progn
(setq loc (list 'LCL (next-lcl)))
(wt-nl "{cl_object " loc "= " key-form ";")
))
(dolist (clause clauses)
(let* ((label (next-label))
(keylist (first clause)))
(wt-nl "if(")
(dolist (keys keylist)
(let ((data-type (info-type (second keys)))
(data-value (third keys)))
(cond ((not (eq (first keys) 'LOCATION))
(cmperr "Found ~s" keys)
(baboon))
((subtypep data-type '(or fixnum symbol character null))
(wt "(" loc "!=" data-value ")"))
(t
(wt "!eql(" loc "," data-value ")"))))
(wt-nl "&&"))
(wt "1)")
(wt-go label)
(let ((*unwind-exit* (cons 'JUMP *unwind-exit*))) (c2expr (cdr clause)))
(wt-label label)))
(if (eq default 't)
(wt-nl "FEerror(\"The ECASE key value ~s is illegal.\",1," loc ");")
(c2expr default))
(unless (eq loc key-form) (wt "}"))
(close-inline-blocks))
(cond ((eq loc t))
((null loc)
(unwind-no-exit label)
(wt-nl) (wt-go label))
(t
(cond ((eq (loc-representation-type loc) :bool)
(wt-nl "if(!(" loc ")){"))
(t
(wt-nl "if((")
(wt-coerce-loc :object loc)
(wt ")==Cnil){")))
(unwind-no-exit label)
(wt-nl) (wt-go label)
(wt "}"))))
;;; ----------------------------------------------------------------------
@ -356,7 +286,3 @@
(put-sysprop 'jump-true 'set-loc #'set-jump-true)
(put-sysprop 'jump-false 'set-loc #'set-jump-false)
(put-sysprop 'case 'c1 #'c1case)
(put-sysprop 'ecase 'c1 #'c1ecase)
(put-sysprop 'case 'c2 #'c2case)

375
src/cmp/cmpinline.lsp
View file

@ -49,19 +49,16 @@
(defun var-changed-in-forms (var forms)
(declare (type var var))
(case (var-kind var)
((LEXICAL FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)
(dolist (form forms)
(when (member var (info-changed-vars (second form)))
(return t))))
(REPLACED (let ((loc (var-loc var)))
(when (and (consp loc) (eq 'VAR (first loc)))
(var-changed-in-forms (second loc) forms))))
(t (dolist (form forms)
(when (or (member var (info-changed-vars (second form)))
(info-sp-change (second form)))
(return t)))))
)
(let ((kind (var-kind var)))
(if (eq kind 'REPLACED)
(let ((loc (var-loc var)))
(when (var-p loc)
(var-changed-in-forms loc forms)))
(let ((check-specials (or (eq kind 'SPECIAL) (eq kind 'GLOBAL))))
(dolist (form forms)
(when (or (member var (info-changed-vars (second form)))
(and check-specials (info-sp-change (second form))))
(return t)))))))
;;; Valid property names for open coded functions are:
;;; :INLINE-ALWAYS
@ -89,7 +86,6 @@
;;; call close-inline-blocks
;;;
(defun inline-args (forms &optional types)
;; all uses of next-lcl may be eliminated??? Beppe
(flet ((all-locations (args &aux (res t))
(dolist (arg args res)
(unless (member (car arg) '(LOCATION VAR SYS:STRUCTURE-REF
@ -108,90 +104,72 @@
(LOCATION
(push (list (form-type form) (third form)) locs))
(VAR
(let ((var (caaddr form)))
(let ((var (third form)))
(if (var-changed-in-forms var (cdr forms))
(let ((lcl-loc (list 'LCL (next-lcl)))
(var-type (var-kind var)))
(wt-nl "{" (rep-type var-type) lcl-loc "= ")
(wt-var var) (wt ";")
(push (list (form-type form)
(if (unboxed var)
lcl-loc
(list 'T lcl-loc))) ; global proclaimed var.
locs)
(let* ((var-rep-type (var-rep-type var))
(lcl (make-lcl-var :rep-type var-rep-type :type (var-type var))))
(wt-nl "{" (rep-type-name var-rep-type) " " lcl "= " var ";")
(push (list (form-type form) lcl) locs)
(incf *inline-blocks*))
(push (list (form-type form) (cons 'VAR (third form)))
locs))))
(push (list (form-type form) var) locs))))
(CALL-GLOBAL
(let* ((fname (third form))
(args (fourth form))
(return-type (info-type (second form)))
(arg-locs (inline-args args))
loc)
(if (and (inline-possible fname)
(not (get-sysprop fname 'C2)) ; no special treatment
(setq loc (inline-function fname arg-locs return-type)))
(let* ((arg-type (first loc))
(and-type (type-and arg-type return-type))
(typed-loc (list and-type (fix-loc loc))))
(cond
((and (member arg-type '(FIXNUM LONG-FLOAT
SHORT-FLOAT BOOLEAN CHARACTER)
:test #'eq)
;; fix to: (bar (+ (bar) y) (bar y))
(all-locations (cdr forms)))
(push typed-loc locs))
((or (need-to-protect (cdr forms))
(and (second loc) ; side-effectp
(cdr forms)))
;; if there are side-effects, order of execution matters
(let* ((var (make-var :loc (next-lcl)
:kind (if (member arg-type
'(T BOOLEAN)
:test #'eq)
'OBJECT arg-type)
:type and-type))
(lcl-var (list 'VAR var)))
;; use a variable of type arg-type to save the value
;; if (return-type >= arg-type)
;; then
;; coerce the value to arg-type
;; otherwise
;; save the value without coercion and return the
;; variable tagged with and-type,
;; so that whoever uses it may coerce it to such type
(wt-nl "{" (rep-type arg-type)) (wt-lcl (var-loc var))
(wt "= " (if (type>= return-type arg-type)
typed-loc loc) ";")
(push (list and-type lcl-var) locs)
(incf *inline-blocks*)))
(t (push typed-loc locs))))
(let* ((temp (list 'TEMP (next-temp)))
;; bindings like c1expr*
(*exit* (next-label))
(*unwind-exit* (cons *exit* *unwind-exit*))
(*lcl* *lcl*)
(*temp* *temp*)
(*destination* temp))
(call-global fname arg-locs nil return-type nil)
(wt-label *exit*)
(push (list (if (eq 'T return-type)
(or (get-return-type fname) 'T)
return-type)
temp) locs)))))
(loc (inline-function fname arg-locs return-type)))
(if loc
(progn
;; If there are side effects, we may not move the C form
;; around and we have to save its value in a variable.
;; We use a variable of type out-type to save the value
;; if (return-type >= out-type)
;; then
;; coerce the value to out-type
;; otherwise
;; save the value without coercion and return the
;; variable tagged with and-type,
;; so that whoever uses it may coerce it to such type
(when (and (consp loc)
(eq (first loc) 'C-INLINE)
(not (all-locations (rest forms)))
(or (need-to-protect (rest forms))
(fifth loc))) ; side effects?
(let* ((and-type (type-and return-type (loc-type loc)))
(out-rep-type (loc-representation-type loc))
(var (make-lcl-var :rep-type out-rep-type :type and-type)))
(wt-nl "{" (rep-type-name out-rep-type) " " var "= " loc ";")
(incf *inline-blocks*)
(setq loc var)))
(push (list (loc-type loc) loc) locs))
;; FIXME! Why is (make-temp-var) before rebinding of *temp*???
(let* ((temp (make-temp-var))
;; bindings like c1expr*
(*exit* (next-label))
(*unwind-exit* (cons *exit* *unwind-exit*))
(*lcl* *lcl*)
(*temp* *temp*)
(*destination* temp))
(call-global fname arg-locs nil return-type nil)
(wt-label *exit*)
(push
(list (if (subtypep 'T return-type)
(or (get-return-type fname) 'T)
return-type)
temp)
locs)))))
(SYS:STRUCTURE-REF
(let ((type (form-type form)))
(if (args-cause-side-effect (cdr forms))
(let* ((temp (list 'TEMP (next-temp)))
(let* ((temp (make-temp-var))
(*destination* temp))
(c2expr* form)
(push (list type temp) locs))
(push (list type
(list 'SYS:STRUCTURE-REF
(second (first
(first (coerce-locs
(inline-args (list (third form)))))
(fourth form)
(fifth form)))
@ -200,13 +178,13 @@
(SYS:INSTANCE-REF
(let ((type (form-type form)))
(if (args-cause-side-effect (cdr forms))
(let* ((temp (list 'TEMP (next-temp)))
(let* ((temp (make-temp-var))
(*destination* temp))
(c2expr* form)
(push (list type temp) locs))
(push (list type
(list 'SYS:INSTANCE-REF
(second (first
(first (coerce-locs
(inline-args (list (third form)))))
(fourth form)
#+nil (fifth form))) ; JJGR
@ -214,144 +192,42 @@
(SETQ
(let ((vref (third form))
(form1 (fourth form)))
(let ((*destination* (cons 'VAR vref))) (c2expr* form1))
(let ((*destination* vref)) (c2expr* form1))
(if (eq (car form1) 'LOCATION)
(push (list (form-type form1) (third form1)) locs)
(setq forms (list* nil ; discarded at iteration
(list 'VAR (second form) vref) (cdr forms))
))))
(t (let ((temp (list 'TEMP (next-temp))))
(t (let ((temp (make-temp-var)))
(let ((*destination* temp)) (c2expr* form))
(push (list (form-type form) temp) locs))))))
)
(defun coerce-locs (args types)
;; each arg is pair (type location).
;; if TYPES is NIL, all types are meant to be T.
;; If type matches the corresponding required type, leave arg as is;
;; otherwise, if type is simple, replace type with coercion to object;
;; otherwise, remove type (WT-LOC will take care of producing an object,
;; except for LCLs).
;;
(do ((args args (cdr args))
(types (or types '(T)) (or (cdr types) '(T)))
(arg-type) (loc))
((null args))
(setq arg-type (car (member (caar args)
'(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT)
:test #'eq))
loc (second (car args)))
(if arg-type
(if (eq arg-type (car types))
(when (and (consp loc) (eq 'LCL (car loc)))
(setf (car args) loc))
(if (consp loc)
(case arg-type
(FIXNUM (if (member (car loc)
;; TEMPs contain object
'(VAR TEMP FIXNUM-VALUE INLINE-FIXNUM
INLINE SI:STRUCTURE-REF T))
(setf (car args) loc)
(setf (caar args) 'FIXNUM->OBJECT)))
(CHARACTER (if (member (car loc)
'(VAR TEMP CHARACTER-VALUE INLINE T
INLINE-CHARACTER SI:STRUCTURE-REF))
(setf (car args) loc)
(setf (caar args) 'CHARACTER->OBJECT)))
(LONG-FLOAT (if (member (car loc)
'(VAR TEMP LONG-FLOAT-VALUE T
INLINE-LONG-FLOAT INLINE
SI:STRUCTURE-REF))
(setf (car args) loc)
(setf (caar args) 'LONG-FLOAT->OBJECT)))
(SHORT-FLOAT (if (member (car loc)
'(VAR TEMP SHORT-FLOAT-VALUE T
INLINE-SHORT-FLOAT INLINE
SI:STRUCTURE-REF))
(setf (car args) loc)
(setf (caar args) 'SHORT-FLOAT->OBJECT))))
(setf (car args) loc)))
(setf (car args) loc)))
args)
;;; this function may go away if we replace all uses of inline-? with
;;; just the type name. Or else we could use a single tag INLINE
;;; and put the type in second position, replacing side-effect-p which
;;; is not used from now on.
(defun fix-loc (loc)
(setf (car loc)
(case (car loc)
(BOOLEAN 'INLINE-COND)
(FIXNUM 'INLINE-FIXNUM)
(CHARACTER 'INLINE-CHARACTER)
(LONG-FLOAT 'INLINE-LONG-FLOAT)
(SHORT-FLOAT 'INLINE-SHORT-FLOAT)
(otherwise 'INLINE)))
loc)
(defun destination-type ()
(if (and (consp *destination*)
(member (car *destination*) '(VAR BIND) :test #'eq))
(var-type (second *destination*))
T))
(loc-type *destination*))
;;;
;;; inline-function:
;;; locs are typed locs as produced by inline-args
;;; returns NIL if inline expansion of the function is not possible
;;;
(defun inline-function (fname locs return-type)
(defun inline-function (fname inlined-locs return-type)
;; Those functions that use INLINE-FUNCTION must rebind
;; the variable *INLINE-BLOCKS*.
(setq return-type (type-and return-type (destination-type)))
(let* ((ii (get-inline-info fname (mapcar #'car locs) return-type))
(fun))
(when ii
(setq fun (fifth ii))
;; remove coercion where not necessary:
(coerce-locs locs (first ii))
(when (and (stringp fun) (char= (char (the string fun) 0) #\@))
(let ((saves nil))
(do* ((i 1 (1+ i))
(char (char (the string fun) i) (char (the string fun) i)))
((char= char #\;))
(declare (fixnum i) (character char))
(push (the fixnum (- (char-code char) #.(char-code #\0))) saves))
(do ((l locs (cdr l))
(n 0 (1+ n))
(locs1 nil))
((endp l) (setq locs (nreverse locs1)))
(declare (fixnum n))
(if (member n saves)
(let* ((loc1 (car l)) (loc loc1) (coersion nil))
(when (and (consp loc1)
(member (car loc1)
'(FIXNUM CHARACTER
LONG-FLOAT SHORT-FLOAT)
:test #'eq))
(setq coersion (car loc1))
(setq loc (second loc1))) ; remove coersion
(if
(or (eq loc 'RETURN)
(member (car loc) '(VAR FIXNUM-VALUE SHORT-FLOAT-VALUE
LONG-FLOAT-VALUE CHARACTER-VALUE VV)
:test #'eq))
(push loc1 locs1)
;; else
(let ((lcl (list 'LCL (next-lcl))))
(push lcl locs1)
(incf *inline-blocks*)
(wt-nl "{" (rep-type coersion) lcl "= " loc1 ";"))))
;; else
(push (car l) locs1)))))
(list (second ii)
(third ii)
fun
locs)))
)
(and (inline-possible fname)
(not (get-sysprop fname 'C2))
(let* ((ii (get-inline-info fname (mapcar #'first inlined-locs)
(type-and return-type (destination-type)))))
(when ii
(let* ((arg-types (first ii))
(out-rep-type (lisp-type->rep-type (second ii)))
(out-type (rep-type->lisp-type (second ii)))
(side-effects-p (third ii))
(fun (fifth ii))
(one-liner t))
(produce-inline-loc inlined-locs arg-types out-rep-type
fun side-effects-p one-liner))))))
(defun get-inline-info (fname types return-type &aux ii iia)
(dolist (x *inline-functions*)
@ -378,21 +254,23 @@
&aux (rts nil)
(number-max nil)
(inline-return-type
(second inline-info)))
(rep-type->lisp-type
(second inline-info))))
;; In sysfun.lsp optimizers must be listed with most specific cases last.
(flet ((float-type-max (t1 t2)
(if t1
(if (or (eq t1 'LONG-FLOAT)
(eq t2 'LONG-FLOAT))
(if (or (subtypep t1 'LONG-FLOAT)
(subtypep t2 'LONG-FLOAT))
'LONG-FLOAT
(if (or (eq t1 'SHORT-FLOAT)
(eq t2 'SHORT-FLOAT))
(if (or (subtypep t1 'SHORT-FLOAT)
(subtypep t2 'SHORT-FLOAT))
'SHORT-FLOAT
'FIXNUM))
t2)))
(if (and (do ((arg-types arg-types (cdr arg-types))
(types (car inline-info) (cdr types))
(arg-type) (type))
(arg-type)
(type))
((or (endp arg-types) (endp types))
(and (endp arg-types) (endp types)))
(setq arg-type (car arg-types)
@ -408,10 +286,10 @@
;; compute max of FIXNUM-FLOAT arguments types
(setq number-max
(float-type-max number-max (first rts))))
((type>= type arg-type)
((type>= (rep-type->lisp-type type) arg-type)
(push type rts))
(t (return nil))))
(or (eq inline-return-type 'BOOLEAN)
(or (eq (second inline-info) :bool)
(if number-max
;; for arithmetic operators we take the maximal type
;; as possible result type
@ -432,7 +310,7 @@
(case (car form)
(LOCATION)
(VAR
(when (var-changed-in-forms (car (third form)) (cdr forms))
(when (var-changed-in-forms (third form) (cdr forms))
(setq res t)))
(CALL-GLOBAL
(let ((fname (third form))
@ -455,59 +333,7 @@
)
(defun close-inline-blocks ()
(dotimes (i *inline-blocks*) (declare (fixnum i)) (wt "}")))
(eval-when (compile eval) ; also in cmptop.lsp
(defmacro parse-index (fun i)
`(multiple-value-bind (a-read endpos)
(parse-integer ,fun :start (1+ ,i) :junk-allowed t)
(setq ,i (1- endpos))
a-read))
)
(defun wt-inline-loc (fun locs &aux (i 0))
(declare (fixnum i))
(cond ((stringp fun)
(when (char= (char (the string fun) 0) #\@)
(setq i 1)
(do ()
((char= (char (the string fun) i) #\;) (incf i))
(incf i)))
(do ((size (length (the string fun)))
(char))
((>= i size))
(declare (fixnum size) (character char))
(setq char (char (the string fun) i))
(if (char= char #\#)
(wt-loc (nth (parse-index fun i) locs))
(princ char *compiler-output1*))
(incf i))
)
(t (apply (coerce fun 'function) locs))))
(defun wt-inline (side-effectp fun locs)
(declare (ignore side-effectp))
(wt-inline-loc fun locs))
(defun wt-inline-cond (side-effectp fun locs)
(declare (ignore side-effectp))
(wt "(") (wt-inline-loc fun locs) (wt "?Ct:Cnil)"))
(defun wt-inline-fixnum (side-effectp fun locs)
(declare (ignore side-effectp))
(wt "MAKE_FIXNUM(") (wt-inline-loc fun locs) (wt ")"))
(defun wt-inline-character (side-effectp fun locs)
(declare (ignore side-effectp))
(wt "CODE_CHAR(") (wt-inline-loc fun locs) (wt ")"))
(defun wt-inline-long-float (side-effectp fun locs)
(declare (ignore side-effectp))
(wt "make_longfloat(") (wt-inline-loc fun locs) (wt ")"))
(defun wt-inline-short-float (side-effectp fun locs)
(declare (ignore side-effectp))
(wt "make_shortfloat(") (wt-inline-loc fun locs) (wt ")"))
(dotimes (i *inline-blocks*) (declare (fixnum i)) (wt #\})))
(defun args-cause-side-effect (forms &aux ii)
(dolist (form forms nil)
@ -528,13 +354,6 @@
;;; ----------------------------------------------------------------------
(put-sysprop 'INLINE 'WT-LOC 'wt-inline)
(put-sysprop 'INLINE-COND 'WT-LOC 'wt-inline-cond)
(put-sysprop 'INLINE-FIXNUM 'WT-LOC 'wt-inline-fixnum)
(put-sysprop 'INLINE-CHARACTER 'WT-LOC 'wt-inline-character)
(put-sysprop 'INLINE-LONG-FLOAT 'WT-LOC 'wt-inline-long-float)
(put-sysprop 'INLINE-SHORT-FLOAT 'WT-LOC 'wt-inline-short-float)
(put-sysprop 'FIXNUM 'WT-LOC 'wt-fixnum-loc)
(put-sysprop 'CHARACTER 'WT-LOC 'wt-character-loc)
(put-sysprop 'LONG-FLOAT 'WT-LOC 'wt-long-float-loc)
@ -544,17 +363,3 @@
;;; Since they are possible locations, we must add:
(put-sysprop 'STRING 'WT-LOC 'wt-loc)
(put-sysprop 'BIT-VECTOR 'WT-LOC 'wt-loc)
(defun wt-fixnum->object (loc)
(wt "MAKE_FIXNUM(" loc ")"))
(defun wt-character->object (loc)
(wt "CODE_CHAR(" loc ")"))
(defun wt-short-float->object (loc)
(wt "make_shortfloat(" loc ")"))
(defun wt-long-float->object (loc)
(wt "make_longfloat(" loc ")"))
(put-sysprop 'FIXNUM->OBJECT 'WT-LOC 'wt-fixnum->object)
(put-sysprop 'CHARACTER->OBJECT 'WT-LOC 'wt-character->object)
(put-sysprop 'LONG-FLOAT->OBJECT 'WT-LOC 'wt-long-float->object)
(put-sysprop 'SHORT-FLOAT->OBJECT 'WT-LOC 'wt-short-float->object)

108
src/cmp/cmplam.lsp
View file

@ -184,16 +184,8 @@
(if (eq 'LOCAL-ENTRY kind)
;; for local entry functions arguments are processed by t3defun
(do ((reqs requireds (cdr reqs))
(reqi (1+ *lcl*) (1+ reqi))
(LCL_i (list 'LCL 0))) ; to allow concurrent compilations
((endp reqs) (setq *lcl* reqi))
(declare (fixnum reqi) (type cons reqs))
(if (eq (var-kind (first reqs)) 'SPECIAL)
(progn
(setf (second LCL_i) reqi)
(bind LCL_i (first reqs)))
(setf (var-loc (first reqs)) reqi)))
(dolist (reqs requireds)
(bind (next-lcl) reqs))
;; For each variable, set its var-loc.
;; For optional parameters, and lexical variables which can be unboxed,
@ -218,9 +210,9 @@
(wt-nl)
(unless block-p
(wt "{") (setq block-p t))
(wt *volatile* (register var) (rep-type (var-kind var)))
(wt *volatile* (register var) (rep-type-name (var-rep-type var)) " ")
(wt-lcl (incf lcl)) (wt ";")
lcl)
`(LCL ,lcl))
(do-decl (var)
(when (local var) ; no LCL needed for SPECIAL or LEX
(setf (var-loc var) (wt-decl var)))))
@ -242,7 +234,7 @@
((endp opt))
(do-decl (first opt))
(when (third opt) (do-decl (third opt))))
(when rest (setq rest-loc `(LCL ,(wt-decl rest)))))
(when rest (setq rest-loc (wt-decl rest))))
(unless (eq 'CALL-LAMBDA kind)
(when (or optionals rest)
@ -256,12 +248,10 @@
;; Bind required parameters.
(do ((reqs requireds (cdr reqs))
(reqi (1+ req0) (1+ reqi))
(LCL_i (list 'LCL 0))) ; to allow concurrent compilations
(reqi (1+ req0) (1+ reqi)))
((endp reqs))
(declare (fixnum reqi) (type cons reqs))
(setf (second LCL_i) reqi)
(bind LCL_i (first reqs)))
(bind `(LCL ,reqi) (first reqs)))
(setq *lcl* lcl))
)
@ -337,9 +327,9 @@
(wt-nl)
(unless block-p
(wt "{") (setq block-p t))
(wt *volatile* (register var) (rep-type (var-kind var)))
(wt *volatile* (register var) (rep-type-name (var-rep-type var)) " ")
(wt-lcl (incf lcl)) (wt ";")
lcl)
`(LCL ,lcl))
(do-decl (var)
(when (local var) ; no LCL needed for SPECIAL or LEX
(setf (var-loc var) (wt-decl var)))))
@ -361,7 +351,7 @@
((endp opt))
(do-decl (first opt))
(when (third opt) (do-decl (third opt))))
(when rest (setq rest-loc `(LCL ,(wt-decl rest))))
(when rest (setq rest-loc (wt-decl rest)))
(do ((key keywords (cddddr key)))
((endp key))
(do-decl (second key))
@ -382,12 +372,10 @@
;; Bind required parameters.
(do ((reqs requireds (cdr reqs))
(reqi (1+ req0) (1+ reqi))
(LCL_i (list 'LCL 0))) ; to allow concurrent compilations
(reqi (1+ req0) (1+ reqi))) ; to allow concurrent compilations
((endp reqs))
(declare (fixnum reqi) (type cons reqs))
(setf (second LCL_i) reqi)
(bind LCL_i (first reqs)))
(bind `(LCL ,reqi) (first reqs)))
(setq *lcl* lcl)
)
@ -655,27 +643,24 @@
(defun c1dm-bad-key (key)
(cmperr "Defmacro-lambda-list contains illegal use of ~s." key))
(defun c2dm (name whole env vl body &aux lcl)
(defun c2dm (name whole env vl body)
(when (or *safe-compile* *compiler-check-args*)
(wt-nl "check_arg(2);"))
(setq lcl (next-lcl))
(when whole
(check-vref whole)
; (setf (var-loc whole) lcl)
(bind (list 'LCL lcl) whole))
(setq lcl (next-lcl))
(when env
(check-vref env)
; (setf (var-loc env) lcl)
(bind (list 'LCL lcl) env))
(let ((lcl (next-lcl)))
(when whole
(check-vref whole)
(bind lcl whole)))
(let ((lcl (next-lcl)))
(when env
(check-vref env)
(bind lcl env)))
(labels ((reserve-v (v)
(if (consp v)
(reserve-vl v)
(when (local v)
(let ((lcl (next-lcl)))
(setf (var-loc v) lcl)
(setf (var-kind v) 'OBJECT)
(wt ",") (wt-lcl lcl)))))
(setf (var-kind v) :OBJECT
(var-loc v) (next-lcl))
(wt "," v))))
(reserve-vl (vl)
(dolist (var (car vl)) (reserve-v var))
@ -691,8 +676,8 @@
(dm-bind-loc (v loc)
(if (consp v)
(let ((lcl (next-lcl)))
(wt-nl "{cl_object ") (wt-lcl lcl) (wt "= " loc ";")
(let ((lcl (make-lcl-var)))
(wt-nl "{cl_object " lcl "= " loc ";")
(dm-bind-vl v lcl)
(wt "}"))
(bind loc v)))
@ -700,9 +685,9 @@
(dm-bind-init (para &aux (v (first para)) (init (second para)))
(if (consp v)
(let* ((*inline-blocks* 0) ; used by inline-args
(lcl (next-lcl))
(loc (second (first (inline-args (list init))))))
(wt-nl) (wt-lcl lcl) (wt "= " loc ";")
(lcl (make-lcl-var))
(loc (first (coerce-locs (inline-args (list init))))))
(wt-nl lcl "= " loc ";")
(dm-bind-vl v lcl)
(close-inline-blocks))
(bind-init v init)))
@ -720,18 +705,18 @@
((endp reqs))
(declare (object reqs))
(when (or *safe-compile* *compiler-check-args*)
(wt-nl "if(endp(") (wt-lcl lcl)
(wt "))FEinvalid_macro_call(" (add-symbol name) ");"))
(wt-nl "if(endp(" lcl "))FEinvalid_macro_call("
(add-symbol name) ");"))
(dm-bind-loc (car reqs) `(CAR ,lcl))
(when (or (cdr reqs) optionals rest key-flag
*safe-compile* *compiler-check-args*)
(wt-nl) (wt-lcl lcl) (wt "=CDR(") (wt-lcl lcl) (wt ");")))
(wt-nl lcl "=CDR(" lcl ");")))
(do ((opts optionals (cdr opts))
(opt))
((endp opts))
(declare (object opts opt))
(setq opt (car opts))
(wt-nl "if(endp(") (wt-lcl lcl) (wt ")){")
(wt-nl "if(endp(" lcl ")){")
(let ((*env* *env*)
(*unwind-exit* *unwind-exit*))
(dm-bind-init opt)
@ -742,16 +727,15 @@
(when (third opt) (dm-bind-loc (third opt) t))
(when (or (cdr opts) rest key-flag
*safe-compile* *compiler-check-args*)
(wt-nl) (wt-lcl lcl) (wt "=CDR(") (wt-lcl lcl) (wt ");"))
(wt-nl lcl "=CDR(" lcl ");"))
(wt "}"))
(when rest (dm-bind-loc rest `(LCL ,lcl)))
(when rest (dm-bind-loc rest lcl))
(when keywords
(let* ((lcl1 (next-lcl))
(loc1 `(LCL ,lcl1)))
(let* ((loc1 (make-lcl-var)))
(wt-nl "{cl_object " loc1 ";")
(dolist (kwd keywords)
(wt-nl loc1 "=ecl_getf(") (wt-lcl lcl)
(wt "," (add-symbol (car kwd)) ",OBJNULL);")
(wt-nl loc1 "=ecl_getf(" lcl "," (add-symbol (car kwd))
",OBJNULL);")
(wt-nl "if(" loc1 "==OBJNULL){")
(let ((*env* *env*)
(*unwind-exit* *unwind-exit*))
@ -765,12 +749,12 @@
(when (and (or *safe-compile* *compiler-check-args*)
(null rest)
(null key-flag))
(wt-nl "if(!endp(") (wt-lcl lcl)
(wt "))FEinvalid_macro_call(" (add-symbol name) ");"))
(wt-nl "if(!endp(" lcl "))FEinvalid_macro_call("
(add-symbol name) ");"))
(when (and (or *safe-compile* *compiler-check-args*)
key-flag
(not allow-other-keys))
(wt-nl "check_other_key(") (wt-lcl lcl) (wt "," (length keywords))
(wt-nl "check_other_key(" lcl "," (length keywords))
(dolist (kwd keywords)
(wt "," (add-symbol (car kwd))))
(wt ");"))
@ -778,11 +762,11 @@
(dm-bind-init aux)))
)
(setq lcl (next-lcl))
(wt-nl "{cl_object ") (wt-lcl lcl) (wt "=CDR(V1)")
(reserve-vl vl) ; declare variables for pattern
(wt ";")
(dm-bind-vl vl lcl)
(let ((lcl (make-lcl-var)))
(wt-nl "{cl_object " lcl "=CDR(V1)")
(reserve-vl vl) ; declare variables for pattern
(wt ";")
(dm-bind-vl vl lcl))
)
(c2expr body)
(wt "}")

80
src/cmp/cmplet.lsp
View file

@ -87,7 +87,7 @@
(defun update-var-type (var type x)
(when (listp x)
(if (and (eq (car x) 'VAR)
(eq var (first (third x))))
(eq var (third x)))
(setf (info-type (second x))
;; some occurrences might be typed with 'the'
(type-and (info-type (second x)) type))
@ -111,24 +111,23 @@
;; Determine which variables are really necessary and create list of init's
;; and list of bindings. Bindings for specials must be done after all inits.
(labels ((do-decl (var lcl)
(labels ((do-decl (var)
(declare (type var var))
(setf (var-loc var) lcl) ; must be set or bind will clobber it
(wt-nl)
(unless block-p
(wt "{") (setq block-p t))
(wt *volatile* (register var) (rep-type (var-kind var)))
(wt-lcl lcl) (wt ";")
(wt *volatile* (register var) (rep-type-name (var-rep-type var)) " "
var ";")
(when (local var)
(wt-comment (var-name var))))
(do-init (var form fl)
(if (and (local var)
(not (args-cause-side-effect (cdr fl))))
;; avoid creating temporary for init
(push (cons (list 'VAR var) form) initials)
(let* ((lcl (next-lcl))
(loc (list 'LCL lcl)))
(do-decl (make-var) lcl)
(push (cons var form) initials)
(let* ((loc (make-lcl-var :rep-type (var-rep-type var)
:type (var-type var))))
(do-decl loc)
(push (cons loc form) initials)
(push (cons var loc) bindings)))))
@ -142,11 +141,12 @@
var (first vl))
(when (and (local var)
(setq used (not (discarded var form body))))
(do-decl var (next-lcl)))
(setf (var-loc var) (next-lcl))
(do-decl var))
(when used
(if (unboxed var)
(push (cons (list 'VAR var) form) initials) ; nil (ccb)
;; LEXICAL, SPECIAL, GLOBAL or OBJECT
(push (cons var form) initials) ; nil (ccb)
;; LEXICAL, SPECIAL, GLOBAL or :OBJECT
(case (car form)
(LOCATION
(if (can-be-replaced var body)
@ -154,22 +154,19 @@
(var-loc var) (third form))
(push (cons var (third form)) bindings)))
(VAR
(let* ((vref1 (third form))
(var1 (car vref1)))
(let* ((var1 (third form)))
(cond ((or (var-changed-in-forms var1 (cdr fl))
(and (member (var-kind var1) '(SPECIAL GLOBAL)
:test #'eq)
(member (var-name var1) prev-ss :test #'eq)))
(and (member (var-kind var1) '(SPECIAL GLOBAL))
(member (var-name var1) prev-ss)))
(do-init var form fl))
((and (can-be-replaced var body)
(member (var-kind var1) '(LEXICAL REPLACED OBJECT)
:test #'eq)
(member (var-kind var1) '(LEXICAL REPLACED :OBJECT))
(not (var-ref-ccb var1))
(not (member var1
(info-changed-vars (second body)))))
(setf (var-kind var) 'REPLACED
(var-loc var) (cons 'VAR vref1)))
(t (push (cons var (cons 'VAR vref1)) bindings)))))
(var-loc var) var1))
(t (push (cons var var1) bindings)))))
(t (do-init var form fl))))
(unless env-grows
(setq env-grows (var-ref-ccb var))))
@ -289,7 +286,7 @@
(nsubst-if form #'(lambda (x)
(and (listp x)
(eq (first x) 'VAR)
(eq var (first (third x)))))
(eq var (third x))))
body)))
(progn
(push var used-vars)
@ -307,7 +304,7 @@
(defun replaceable (var form)
(case (car form)
(VAR
(if (eq var (first (third form)))
(if (eq var (third form))
(throw var T)
T))
((LOCATION SYS:STRUCTURE-REF) T)
@ -341,24 +338,21 @@
(setf (var-kind var) 'REPLACED
(var-loc var) (third form))))
(VAR
(let* ((vref1 (third form))
(var1 (car vref1)))
(let* ((var1 (third form)))
(declare (type var var1))
(when (and (can-be-replaced* var body (cdr fl))
(member (var-kind var1)
'(LEXICAL REPLACED OBJECT) :test #'eq)
(member (var-kind var1) '(LEXICAL REPLACED :OBJECT))
(not (var-ref-ccb var1))
(not (var-changed-in-forms var1 (cdr fl)))
(not (member var1 (info-changed-vars (second body)))))
(setf (var-kind var) 'REPLACED
(var-loc var) (cons 'VAR vref1))))))
(var-loc var) var1)))))
(unless env-grows
(setq env-grows (var-ref-ccb var))))
(when (and kind (not (eq (var-kind var) 'REPLACED)))
(setf (var-loc var) (next-lcl))
(bind (next-lcl) var)
(wt-nl) (unless block-p (wt "{") (setq block-p t))
(wt *volatile* (register var) (rep-type kind))
(wt-lcl (var-loc var)) (wt ";")
(wt *volatile* (register var) (rep-type-name kind) " " var ";")
(wt-comment (var-name var)))
)
@ -376,15 +370,17 @@
(setq var (car vl)
form (car fl))
(case (var-kind var)
((FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT) ; (local var)
(let ((*destination* `(VAR ,var))) ; nil (ccb)
(c2expr* form)))
(REPLACED)
(t (case (car form)
(LOCATION (bind (third form) var))
(VAR (bind (cons 'VAR (third form)) var))
(t (bind-init var form))))))
((LEXICAL SPECIAL GLOBAL)
(case (car form)
(LOCATION (bind (third form) var))
(VAR (bind (third form) var))
(t (bind-init var form))))
(t ; local var
(let ((*destination* var)) ; nil (ccb)
(c2expr* form)))
)
)
(c2expr body)
(when block-p (wt-nl "}"))
@ -397,7 +393,7 @@
(last-form (car (last (third x)))))
((LET LET* FLET LABELS BLOCK CATCH)
(last-form (car (last x))))
(VAR (car (third x)))
(VAR (third x))
(t x))))
(and (not (args-cause-side-effect (list form)))
(or (< (var-ref var) 1)
@ -407,11 +403,11 @@
(defun can-be-replaced (var body)
(declare (type var var))
(and (eq (var-kind var) 'OBJECT)
(and (eq (var-kind var) :OBJECT)
(< (var-ref var) *register-min*)
(not (member var (info-changed-vars (second body))))))
#| (and (or (eq (var-kind var) 'LEXICAL)
(and (eq (var-kind var) 'OBJECT)
(and (eq (var-kind var) :OBJECT)
(< (var-ref var) *register-min*)))
(not (var-ref-ccb var))
(not (member var (info-changed-vars (second body)))))

139
src/cmp/cmploc.lsp
View file

@ -16,19 +16,14 @@
;;; NIL
;;; T
;;; 'VALUES'
;;; var-object
;;; ( 'VALUE' i ) VALUES(i)
;;; ( 'VAR' var-object ) ; ccb
;;; ( 'VV' vv-index )
;;; ( 'LCL' lcl ) local variable, type unboxed
;;; ( 'TEMP' temp ) local variable, type object
;;; ( 'CALL' fun narg locs fname ) locs are locations containing the arguments
;;; ( 'CALL-LOCAL' fun lex closure args narg fname )
;;; ( 'INLINE' side-effect-p fun/string locs ) fun is applied to locs
;;; ( 'INLINE-COND' side-effect-p fun/string locs )
;;; ( 'INLINE-FIXNUM' side-effect-p fun/string locs )
;;; ( 'INLINE-CHARACTER' side-effect-p fun/string locs )
;;; ( 'INLINE-LONG-FLOAT' side-effect-p fun/string locs )
;;; ( 'INLINE-SHORT-FLOAT' side-effect-p fun/string locs )
;;; ( 'C-INLINE' output-type fun/string locs side-effects output-var )
;;; ( 'CAR' lcl )
;;; ( 'CADR' lcl )
;;; ( 'FDEFINITION' vv-index )
@ -37,12 +32,6 @@
;;; ( 'CHARACTER-VALUE' character-code )
;;; ( 'LONG-FLOAT-VALUE' long-float-value vv )
;;; ( 'SHORT-FLOAT-VALUE' short-float-value vv )
;;;; These are never passed to unwind-exit:
;;; ( 'FIXNUM->OBJECT' loc )
;;; ( 'CHARACTER->OBJECT' loc )
;;; ( 'LONG-FLOAT->OBJECT' loc )
;;; ( 'SHORT-FLOAT->OBJECT' loc )
;;; Valid *DESTINATION* locations are:
;;;
@ -54,7 +43,7 @@
;;; 'RETURN-OBJECT
;;; 'TRASH' The value may be thrown away.
;;; 'VALUES'
;;; ( 'VAR' var-object ) ; ccb
;;; var-object
;;; ( 'LCL' lcl )
;;; ( 'LEX' lex-address )
;;; ( 'BIND' var alternative ) ; alternative is optional
@ -68,34 +57,35 @@
:test #'eq))))
(case *destination*
(VALUES
(cond (is-call (wt-nl "VALUES(0)=" loc ";"))
((eq loc 'VALUES))
(t (wt-nl "VALUES(0)=" loc "; NValues=1;"))))
(cond (is-call
(wt-nl "VALUES(0)=") (wt-coerce-loc :object loc) (wt ";"))
((eq loc 'VALUES) (return-from set-loc))
(t
(wt-nl "VALUES(0)=") (wt-coerce-loc :object loc) (wt "; NValues=1;"))))
(RETURN
(cond ((or is-call (eq loc 'VALUES)) (wt-nl "value0=" loc ";"))
((eq loc 'RETURN))
(t (wt-nl "value0=" loc "; NValues=1;"))))
(cond ((or is-call (eq loc 'VALUES))
(wt-nl "value0=") (wt-coerce-loc :object loc) (wt ";"))
((eq loc 'RETURN) (return-from set-loc))
(t
(wt-nl "value0=") (wt-coerce-loc :object loc) (wt "; NValues=1;"))))
(TRASH
(cond (is-call (wt-nl "(void)" loc ";"))
((and (consp loc)
(member (car loc)
'(INLINE INLINE-COND INLINE-FIXNUM
INLINE-CHARACTER INLINE-LONG-FLOAT
INLINE-SHORT-FLOAT)
:test #'eq)
(second loc))
;;; Removed (void) specifier, for the Prolog inline code.
;;; (wt-nl "(void)(") (wt-inline t (third loc) (fourth loc))
(wt-nl) (wt-inline t (third loc) (fourth loc))
(wt ";"))))
(eq (first loc) 'C-INLINE)
(fifth loc)) ; side effects?
(wt-nl loc ";"))))
(t (cond
((var-p *destination*)
(set-var loc *destination*))
((or (not (consp *destination*))
(not (symbolp (car *destination*))))
(baboon))
((setq fd (get-sysprop (car *destination*) 'SET-LOC))
(apply fd loc (cdr *destination*)))
((setq fd (get-sysprop (car *destination*) 'WT-LOC))
(wt-nl) (apply fd (cdr *destination*)) (wt "= " loc ";"))
(wt-nl) (apply fd (cdr *destination*)) (wt "= ")
(wt-coerce-loc (loc-representation-type *destination*) loc)
(wt ";"))
(t (baboon)))))
)
@ -108,6 +98,8 @@
(wt "VALUES(0)"))
((eq loc 'VA-ARG)
(wt "cl_va_arg(args)"))
((var-p loc)
(wt-var loc))
((or (not (consp loc))
(not (symbolp (car loc))))
(baboon))
@ -121,13 +113,13 @@
'(RETURN RETURN-FIXNUM RETURN-CHARACTER RETURN-SHORT-FLOAT
RETURN-LONG-FLOAT RETURN-OBJECT)))
(defun wt-car (lcl) (wt "CAR(") (wt-lcl lcl) (wt ")"))
(defun wt-car (loc) (wt "CAR(" loc ")"))
(defun wt-cdr (lcl) (wt "CDR(") (wt-lcl lcl) (wt ")"))
(defun wt-cdr (loc) (wt "CDR(" loc ")"))
(defun wt-cadr (lcl) (wt "CADR(") (wt-lcl lcl) (wt ")"))
(defun wt-cadr (loc) (wt "CADR(" loc ")"))
(defun wt-lcl (lcl) (wt "V" lcl))
(defun wt-lcl (lcl) (unless (numberp lcl) (error)) (wt "V" lcl))
(defun wt-vv (vv)
(if (numberp vv)
@ -141,77 +133,22 @@
(wt "T" temp))
(defun wt-number (value &optional vv)
(typecase value
(fixnum (wt "MAKE_FIXNUM(" value ")"))
(t (wt vv))))
(wt value))
(defun wt-character (value &optional vv)
(wt (format nil "CODE_CHAR('\\~O')" value)))
(defun wt-fixnum-loc (loc)
(if (consp loc)
(case (car loc)
(VAR
(if (eq (var-kind (second loc)) 'FIXNUM)
(wt-lcl (var-loc (second loc)))
(wt "fix(" loc ")")))
(INLINE-FIXNUM
(wt-inline-loc (third loc) (fourth loc)))
(FIXNUM-VALUE
(wt (second loc)))
((INLINE-SHORT-FLOAT INLINE-LONG-FLOAT)
(wt "((cl_fixnum)(")
(wt-inline-loc (third loc) (fourth loc))
(wt "))"))
(t (wt "fix(" loc ")")))
(wt "fix(" loc ")")))
(defun wt-character-loc (loc)
(if (consp loc)
(case (car loc)
(VAR
(if (eq (var-kind (second loc)) 'CHARACTER)
(wt-lcl (var-loc (second loc)))
(wt "char_code(" loc ")")))
(INLINE-CHARACTER
(wt-inline-loc (third loc) (fourth loc)))
(CHARACTER-VALUE
(wt (second loc)))
(t (wt "char_code(" loc ")")))
(wt "char_code(" loc ")")))
(defun wt-long-float-loc (loc)
(if (consp loc)
(case (car loc)
(VAR
(if (eq (var-kind (second loc)) 'LONG-FLOAT)
(wt-lcl (var-loc (second loc)))
(wt "lf(" loc ")")))
(INLINE-LONG-FLOAT
(wt-inline-loc (third loc) (fourth loc)))
(LONG-FLOAT-VALUE
(wt (second loc)))
(t (wt "lf(" loc ")")))
(wt "lf(" loc ")")))
(defun wt-short-float-loc (loc)
(if (consp loc)
(case (car loc)
(VAR
(if (eq (var-kind (second loc)) 'SHORT-FLOAT)
(wt-lcl (var-loc (second loc)))
(wt "sf(" loc ")")))
(INLINE-SHORT-FLOAT
(wt-inline-loc (third loc) (fourth loc)))
(SHORT-FLOAT-VALUE
(wt (second loc)))
(t (wt "sf(" loc ")")))
(wt "sf(" loc ")")))
(wt (format nil "'\\~O'" value)))
(defun wt-value (i) (wt "VALUES(" i ")"))
(defun wt-keyvars (i) (wt "keyvars[" i "]"))
(defun loc-refers-to-special (loc)
(unless (atom loc)
(case (first loc)
(BIND t)
(C-INLINE t) ; We do not know, so guess yes
(otherwise nil))))
;;; -----------------------------------------------------------------
(put-sysprop 'TEMP 'WT-LOC #'wt-temp)
@ -221,12 +158,8 @@
(put-sysprop 'CDR 'WT-LOC #'wt-cdr)
(put-sysprop 'CADR 'WT-LOC #'wt-cadr)
(put-sysprop 'FIXNUM-VALUE 'WT-LOC #'wt-number)
(put-sysprop 'FIXNUM-LOC 'WT-LOC #'wt-fixnum-loc) ; used in cmpfun.lsp
(put-sysprop 'CHARACTER-VALUE 'WT-LOC #'wt-character)
;(put-sysprop 'CHARACTER-LOC 'WT-LOC #'wt-character-loc)
(put-sysprop 'LONG-FLOAT-VALUE 'WT-LOC #'wt-number)
;(put-sysprop 'LONG-FLOAT-LOC 'WT-LOC #'wt-long-float-loc)
(put-sysprop 'SHORT-FLOAT-VALUE 'WT-LOC #'wt-number)
;(put-sysprop 'SHORT-FLOAT-LOC 'WT-LOC #'wt-short-float-loc)
(put-sysprop 'VALUE 'WT-LOC #'wt-value)
(put-sysprop 'KEYVARS 'WT-LOC #'wt-keyvars)

2
src/cmp/cmpmain.lsp
View file

@ -219,7 +219,7 @@ int init_~A(cl_object cblock)
init-name "CODE" prologue-code init-name epilogue-code))
(compiler-cc c-name o-name)
(apply #'shared-cc output-name o-name ld-flags)))
;(delete-file c-name)
(delete-file c-name)
(delete-file o-name)
output-name))

58
src/cmp/cmpmap.lsp
View file

@ -22,14 +22,13 @@
(defun c2mapcar (funob car-p args &aux (*inline-blocks* 0))
(let ((label (next-label*))
(value-loc (list 'TEMP (next-temp)))
(handy (list 'lcl (next-lcl)))
(value-loc (make-temp-var))
(handy (make-lcl-var :type 'T))
(handies (mapcar #'(lambda (x) (declare (ignore x))
(list 'lcl (next-lcl)))
(make-lcl-var :type 'T))
args))
(save (save-funob funob)))
(setq args (push-changed-vars (coerce-locs (inline-args args) nil)
funob))
(setq args (push-changed-vars (coerce-locs (inline-args args)) funob))
(wt-nl "{cl_object " handy ";")
(dolist (loc handies)
(wt-nl "cl_object " loc "= " (car args) ";")
@ -46,15 +45,14 @@
(wt "}")
(wt-nl value-loc "=" handy "=CONS(Cnil,Cnil);")
(wt-label label)
(let* ((*destination* (list 'CAR (cadr handy)))
(let* ((*destination* (list 'CAR handy))
(*exit* (next-label))
(*unwind-exit* (cons *exit* *unwind-exit*)))
(c2funcall funob
(if car-p
(mapcar
#'(lambda (loc)
(list 'LOCATION *info* (list 'CAR (cadr loc))))
handies)
(mapcar #'(lambda (loc)
(list 'LOCATION *info* (list 'CAR loc)))
handies)
(mapcar #'(lambda (loc) (list 'LOCATION *info* loc))
handies))
save)
@ -62,12 +60,12 @@
(cond (*safe-compile*
(wt-nl "if(endp(" (car handies) "=CDR(" (car handies) "))")
(dolist (loc (cdr handies))
(wt "||endp(" loc "=CDR(" loc "))"))
(wt "||endp(" loc "=CDR(" loc "))"))
(wt "){"))
(t
(wt-nl "if((" (car handies) "=CDR(" (car handies) "))==Cnil")
(dolist (loc (cdr handies))
(wt "||(" loc "=CDR(" loc "))==Cnil"))
(wt "||(" loc "=CDR(" loc "))==Cnil"))
(wt "){")))
(unwind-exit value-loc 'jump)
(wt "}")
@ -82,16 +80,16 @@
(let ((label (next-label*))
value-loc
(handies (mapcar #'(lambda (x) (declare (ignore x))
(list 'LCL (next-lcl)))
(make-lcl-var))
args))
(save (save-funob funob)))
(setq args (push-changed-vars (coerce-locs (inline-args args) nil)
(setq args (push-changed-vars (coerce-locs (inline-args args))
funob))
(wt-nl "{")
;; preserve first argument:
(if (eq 'RETURN (car args))
(progn
(setq value-loc (list 'LCL (next-lcl)))
(setq value-loc (make-lcl-var))
(wt-nl "cl_object " value-loc "= " (car args) ";"))
(setq value-loc (car args)))
(dolist (loc handies)
@ -113,10 +111,9 @@
(*unwind-exit* (cons *exit* *unwind-exit*)))
(c2funcall funob
(if car-p
(mapcar
#'(lambda (loc)
(list 'LOCATION *info* (list 'CAR (cadr loc))))
handies)
(mapcar #'(lambda (loc)
(list 'LOCATION *info* (list 'CAR loc)))
handies)
(mapcar #'(lambda (loc) (list 'LOCATION *info* loc))
handies))
save)
@ -141,13 +138,13 @@
(defun c2mapcan (funob car-p args &aux (*inline-blocks* 0))
(let ((label (next-label*))
(value-loc (list 'TEMP (next-temp)))
(handy (list 'LCL (next-lcl)))
(value-loc (make-temp-var))
(handy (make-lcl-var))
(handies (mapcar #'(lambda (x) (declare (ignore x))
(list 'LCL (next-lcl)))
(make-lcl-var))
args))
(save (save-funob funob)))
(setq args (push-changed-vars (coerce-locs (inline-args args) nil)
(setq args (push-changed-vars (coerce-locs (inline-args args))
funob))
(wt-nl "{cl_object " handy ";")
(dolist (loc handies)
@ -165,16 +162,15 @@
(wt "}")
(wt-nl value-loc "=" handy "=CONS(Cnil,Cnil);")
(wt-label label)
(let* ((*destination* (list 'CDR (cadr handy)))
(let* ((*destination* (list 'CDR handy))
(*exit* (next-label))
(*unwind-exit* (cons *exit* *unwind-exit*))
)
(c2funcall funob
(if car-p
(mapcar
#'(lambda (loc)
(list 'LOCATION *info* (list 'CAR (cadr loc))))
handies)
(mapcar #'(lambda (loc)
(list 'LOCATION *info* (list 'CAR loc)))
handies)
(mapcar #'(lambda (loc) (list 'LOCATION *info* loc))
handies))
save)
@ -203,10 +199,8 @@
(defun push-changed-vars (locs funob &aux (locs1 nil) (forms (list funob)))
(dolist (loc locs (nreverse locs1))
(if (and (consp loc)
(eq (car loc) 'VAR)
(var-changed-in-forms (cadr loc) forms))
(let ((temp (list 'TEMP (next-temp))))
(if (and (var-p loc) (var-changed-in-forms loc forms))
(let ((temp (make-temp-var)))
(wt-nl temp "= " loc ";")
(push temp locs1))
(push loc locs1))))

28
src/cmp/cmpmulti.lsp
View file

@ -22,8 +22,7 @@
)
(defun c2multiple-value-call (funob forms)
(let ((tot (list 'LCL (next-lcl)))
(nr (list 'LCL (next-lcl)))
(let ((tot (make-lcl-var :rep-type :cl-index))
(loc (save-funob funob)))
(wt-nl "{ cl_index " tot "=0;")
(let ((*unwind-exit* `((STACK ,tot) ,@*unwind-exit*)))
@ -46,7 +45,7 @@
(if (eq 'TRASH *destination*)
;; dont bother saving values
(c2progn (cons form forms))
(let ((nr `(LCL ,(next-lcl))))
(let ((nr (make-lcl-var :type :cl-index)))
(let ((*destination* 'VALUES)) (c2expr* form))
(wt-nl "{ cl_index " nr "=cl_stack_push_values();")
(let ((*destination* 'TRASH)
@ -86,7 +85,7 @@
(unwind-exit 'RETURN))
(1 (c2expr (first forms)))
(t (let* ((*inline-blocks* 0)
(forms (nreverse (inline-args forms))))
(forms (nreverse (coerce-locs (inline-args forms)))))
;; 1) By inlining arguments we make sure that VL has no call to funct.
;; 2) Reverse args to avoid clobbering VALUES(0)
(wt-nl "NValues=" nv ";")
@ -94,7 +93,7 @@
(i (1- (length forms)) (1- i)))
((null vl))
(declare (fixnum i))
(wt-nl "VALUES(" i ")=" (second (first vl)) ";"))
(wt-nl "VALUES(" i ")=" (first vl) ";"))
(unwind-exit 'VALUES)
(close-inline-blocks))))))
@ -124,7 +123,7 @@
(c1expr* (second args) info)))
(setq var (c1vref var))
(push var vrefs)
(push (first var) (info-changed-vars info)))))
(push var (info-changed-vars info)))))
(defun multiple-value-check (vrefs form)
(and (rest vrefs)
@ -138,7 +137,7 @@
(defun c2multiple-value-setq (vrefs form)
(multiple-value-check vrefs form)
(let* ((*lcl* *lcl*)
(nr (list 'LCL (next-lcl))))
(nr (make-lcl-var :type :int)))
(let ((*destination* 'VALUES)) (c2expr* form))
(wt-nl "{int " nr "=NValues;")
(do ((vs vrefs (rest vs))
@ -148,13 +147,13 @@
(declare (fixnum i))
(setq vref (first vs))
(wt-nl "if (" nr ">0) {")
(set-var (list 'VALUE i) (first vref)) ; (second vref) ccb
(set-var (list 'VALUE i) vref) ; (second vref) ccb
(unless (endp (rest vs)) (wt-nl nr "--;"))
(wt-nl "} else {") (set-var nil (first vref)) ; (second vref) ccb
(wt-nl "} else {") (set-var nil vref) ; (second vref) ccb
(wt "}"))
(unless (eq *exit* 'RETURN) (wt-nl))
(wt-nl "if (NValues>1) NValues=1;}")
(unwind-exit (if vrefs (caar vrefs) '(VALUE 0)))))
(unwind-exit (if vrefs (first vrefs) '(VALUE 0)))))
(defun c1multiple-value-bind (args &aux (info (make-info))
(vars nil) (vnames nil) init-form
@ -193,7 +192,7 @@
(*lcl* *lcl*)
(labels nil)
(env-grows nil)
(nr (list 'LCL (next-lcl))))
(nr (make-lcl-var :type :int)))
;; 1) Retrieve the number of output values
(wt-nl "{ int " nr "=NValues;")
@ -203,10 +202,9 @@
(declare (type var var))
(let ((kind (local var)))
(if kind
(let ((lcl (next-lcl)))
(setf (var-loc var) lcl)
(wt-nl *volatile* (register var) (rep-type kind)) (wt-lcl lcl)
(wt ";")
(progn
(bind (next-lcl) var)
(wt-nl *volatile* (register var) (rep-type-name kind) " " var ";")
(wt-comment (var-name var)))
(unless env-grows (setq env-grows (var-ref-ccb var))))))

2
src/cmp/cmpspecial.lsp
View file

@ -82,7 +82,7 @@
(incf (var-ref (fun-var funob)))
(list 'VAR (make-info :referred-vars vars
:local-referred vars)
vars))
(first vars)))
`(FUNCTION ,(make-info :sp-change
(not (and (symbolp fun)
(get-sysprop fun 'NO-SP-CHANGE))))

8
src/cmp/cmptag.lsp
View file

@ -139,12 +139,12 @@
(let ((env-lvl *env-lvl*))
(wt-nl "{ volatile cl_object env" (incf *env-lvl*)
" = env" env-lvl ";")))
(when (eq 'OBJECT (var-kind tag-loc))
(when (eq :OBJECT (var-kind tag-loc))
(setf (var-loc tag-loc) (next-lcl))
(wt-nl "{ cl_object ") (wt-var tag-loc) (wt ";")
(wt-nl "{ cl_object " tag-loc ";")
(setq env-grows t)) ; just to ensure closing the block
(bind "new_frame_id()" tag-loc)
(wt-nl "if (frs_push(FRS_CATCH,") (wt-var tag-loc) (wt ")) {")
(wt-nl "if (frs_push(FRS_CATCH," tag-loc ")) {")
;; Allocate labels.
(dolist (tag body)
(when (and (tag-p tag) (plusp (tag-ref tag)))
@ -207,7 +207,7 @@
(clb (setf (tag-ref-clb tag) t
(var-kind var) 'LEXICAL))
(unw (unless (var-kind var)
(setf (var-kind var) 'OBJECT))))
(setf (var-kind var) :OBJECT))))
(incf (var-ref var))
(incf (tag-ref tag))
(push var (info-local-referred info)) ; no pushnew

44
src/cmp/cmptop.lsp
View file

@ -102,7 +102,6 @@
(wt-h "#endif")
;;; Initialization function.
(let* ((*lcl* 0) (*lex* 0) (*max-lex* 0) (*max-env* 0) (*max-temp* 0)
(*unboxed* nil)
(*reservation-cmacro* (next-cmacro))
(c-output-file *compiler-output1*)
(*compiler-output1* (make-string-output-stream))
@ -171,7 +170,7 @@
(wt-h "#ifdef __cplusplus")
(wt-h "}")
(wt-h "#endif")
(wt-h1 top-output-string))
(wt-nl top-output-string))
(defun t1eval-when (args &aux (load-flag nil) (compile-flag nil))
(when (endp args) (too-few-args 'eval-when 1 0))
@ -237,7 +236,7 @@
(setf (info-volatile (second lambda-expr)) t))
(multiple-value-bind (decl body doc)
(si::process-declarations (cddr args) nil)
(cond ((assoc 'si::c-local decl)
(cond ((and (assoc 'si::c-local decl) *allow-c-local-declaration*)
(setq no-entry t))
((setq doc (si::expand-set-documentation fname 'function doc))
(t1expr `(progn ,@doc)))))
@ -346,7 +345,6 @@
(*volatile* (when lambda-expr
(volatile (second lambda-expr))))
(*lcl* 0) (*temp* 0) (*max-temp* 0)
(*next-unboxed* 0) (*unboxed* nil)
(*lex* *lex*) (*max-lex* *max-lex*)
(*env* *env*) (*max-env* 0) (*level* *level*))
(setq *funarg-vars* funarg-vars)
@ -372,25 +370,25 @@
(push (list fname cfun (second inline-info) (third inline-info))
*global-entries*)
(wt-comment "local entry for function " fname)
(let ((string
(let*((ret-type (rep-type-name (lisp-type->rep-type (third inline-info))))
(string
(with-output-to-string (*compiler-output1*)
(wt-nl1 "static " (rep-type (third inline-info)) "LI" cfun "(")
(do ((vl requireds (cdr vl))
(types (second inline-info) (cdr types))
(prev-type nil) (var)
(lcl (1+ *lcl*) (1+ lcl)))
(wt-nl1 "static " ret-type " LI" cfun "(")
(do* ((vl requireds (cdr vl))
(types (second inline-info) (cdr types))
var rep-type
(lcl (1+ *lcl*) (1+ lcl)))
((endp vl))
(declare (fixnum lcl))
(setq var (first vl))
(setq var (first vl)
rep-type (lisp-type->rep-type (car types)))
(when (member (car types)
'(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT)
:test #'eq)
;; so that c2lambda-expr will know its proper type.
(setf (var-kind var) (car types)))
(when prev-type (wt ","))
(wt *volatile* (register var)
(rep-type (car types)))
(setq prev-type (car types))
(setf (var-kind var) rep-type))
(unless (eq vl requireds) (wt ","))
(wt *volatile* (register var) (rep-type-name rep-type) " ")
(wt-lcl lcl))
(wt ")"))))
(wt-h string ";")
@ -449,8 +447,7 @@
)
(defun wt-function-epilogue (&optional closure-p)
(push (cons *reservation-cmacro* (+ *max-temp* (length *unboxed*)))
*reservations*)
(push (cons *reservation-cmacro* *max-temp*) *reservations*)
(wt-h "#define VT" *reservation-cmacro*)
(when (plusp *max-temp*)
(wt-h1 " cl_object ")
@ -459,8 +456,6 @@
(unless (= (1+ i) *max-temp*) (wt-h1 ",")))
(wt-h1 ";"))
; (wt-h "#define VU" *reservation-cmacro*)
; (when *unboxed*
; (format *compiler-output2* " ~{~{~aU~a; ~}~}" *unboxed*))
(wt-h "#define VLEX" *reservation-cmacro*)
(when (plusp *max-lex*)
(wt-h1 " cl_object lex") (wt-h1 *level*)
@ -585,7 +580,6 @@
(defun t3defmacro (fname cfun macro-lambda ppn sp
&aux (*lcl* 0) (*temp* 0) (*max-temp* 0)
(*lex* *lex*) (*max-lex* *max-lex*)
(*next-unboxed* 0) *unboxed*
(*env* *env*) (*max-env* 0) (*level* *level*)
(*volatile*
(if (get-sysprop fname 'CONTAINS-SETJMP) " volatile " ""))
@ -656,7 +650,7 @@
(let* ((*exit* (next-label))
(*unwind-exit* (list *exit*))
(*temp* *temp*)
(*destination* `(TEMP ,(next-temp))))
(*destination* (make-temp-var)))
(c2expr form)
(wt-nl "cl_defvar(" vv "," *destination* ");")
(wt-label *exit*)))
@ -728,8 +722,8 @@
(defun parse-cvspecs (x &aux (cvspecs nil))
(dolist (cvs x (nreverse cvspecs))
(cond ((symbolp cvs)
(push (list 'OBJECT (string-downcase (symbol-name cvs))) cvspecs))
((stringp cvs) (push (list 'OBJECT cvs) cvspecs))
(push (list :OBJECT (string-downcase (symbol-name cvs))) cvspecs))
((stringp cvs) (push (list :OBJECT cvs) cvspecs))
((and (consp cvs)
(member (car cvs) '(OBJECT CHAR INT FLOAT DOUBLE)))
(dolist (name (cdr cvs))
@ -779,7 +773,7 @@
(analyze-regs (info-referred-vars (second lambda-expr)))
(let* ((*lcl* 0) (*temp* 0) (*max-temp* 0)
(*lex* 0) (*max-lex* 0) (*next-unboxed* 0) *unboxed*
(*lex* 0) (*max-lex* 0)
(*env* (fun-env fun)) ; continue growing env
(*max-env* *env*) (*env-lvl* 0)
(*level* level)

1
src/cmp/cmputil.lsp
View file

@ -77,6 +77,7 @@
(defun baboon (&aux (*print-case* :upcase))
(print-current-form)
(error "~&;;; A bug was found in the compiler. Contact worm@arrakis.es.~%")
(format
t "~&;;; A bug was found in the compiler. Contact worm@arrakis.es.~%")
(incf *error-count*)

168
src/cmp/cmpvar.lsp
View file

@ -135,24 +135,32 @@
;; if the variable can be stored locally, set it var-kind to its type
(setf (var-kind var)
(if (> (var-ref var) 1)
(let ((type (var-type var)))
(cond ((type>= 'FIXNUM type) 'FIXNUM)
((type>= 'CHARACTER type) 'CHARACTER)
((type>= 'LONG-FLOAT type) 'LONG-FLOAT)
((type>= 'SHORT-FLOAT type) 'SHORT-FLOAT)
(t 'OBJECT)))
'OBJECT))))
(lisp-type->rep-type (var-type var))
:OBJECT))))
)
(defun c1var (name)
(let ((info (make-info))
(vref (c1vref name)))
(push (car vref) (info-referred-vars info))
(push (car vref) (info-local-referred info))
(setf (info-type info) (var-type (car vref)))
(unless (var-p vref)
;; This might be the case if there is a symbol macrolet
(return-from c1var vref))
(push vref (info-referred-vars info))
(push vref (info-local-referred info))
(setf (info-type info) (var-type vref))
(list 'VAR info vref))
)
(defun make-lcl-var (&key rep-type (type 'T))
(unless rep-type
(setq rep-type (if type (lisp-type->rep-type type) :object)))
(unless type
(setq type 'T))
(make-var :kind rep-type :type type :loc `(LCL ,(incf *lcl*))))
(defun make-temp-var (&optional (type 'T))
(make-var :kind :object :type type :loc `(TEMP ,(next-temp))))
;;; A variable reference (vref for short) is a list: pair
;;; ( var-object ) Beppe(ccb) ccb-reference )
@ -163,6 +171,7 @@
((eq var 'LB) (setq clb t)) ; level boundary
((consp var)
(when (eq (first var) name) ; symbol macrolet
(baboon)
(return-from c1vref (c1expr (second var)))))
((eq (var-name var) name)
(when (minusp (var-ref var)) ; IGNORE.
@ -173,7 +182,7 @@
(var-loc var) 'OBJECT)) ; replace a previous 'CLB
(clb (setf (var-loc var) 'CLB))))
(incf (var-ref var))
(return-from c1vref (list var))))) ; ccb
(return-from c1vref var)))) ; ccb
(let ((var (sch-global name)))
(unless var
(unless (or (sys:specialp name) (check-global name))
@ -183,9 +192,10 @@
:loc (add-symbol name)
:type (or (get-sysprop name 'CMP-TYPE) t)))
(push var *undefined-vars*))
(list var)) ; ccb
var) ; ccb
)
;;; At each variable binding, the variable is added to *vars* which
;;; emulates the environment.
;;; The index is computed, which is used by similar to compare functions.
@ -195,14 +205,13 @@
(push v *vars*))
(defun unboxed (var)
(member (var-kind var) '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT)
:test #'eq))
(not (eq (var-rep-type var) :object)))
(defun local (var)
(car (member (var-kind var) '(FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)
:test #'eq)))
(and (not (member (var-kind var) '(LEXICAL SPECIAL GLOBAL REPLACED)))
(var-kind var)))
(defun c2var (vref) (unwind-exit (cons 'VAR vref)))
(defun c2var (vref) (unwind-exit vref))
(defun c2location (loc) (unwind-exit loc))
@ -217,51 +226,43 @@
(GLOBAL (if *safe-compile*
(wt "symbol_value(" var-loc ")")
(wt "(" var-loc "->symbol.dbind)")))
(t (case (var-kind var)
(FIXNUM (wt "MAKE_FIXNUM"))
(CHARACTER (wt "CODE_CHAR"))
(LONG-FLOAT (wt "make_longfloat"))
(SHORT-FLOAT (wt "make_shortfloat"))
(OBJECT)
(t (baboon)))
(wt "(") (wt-lcl var-loc) (wt ")"))
(t (wt var-loc))
))
(defun var-rep-type (var)
(case (var-kind var)
((LEXICAL SPECIAL GLOBAL) :object)
(REPLACED (loc-representation-type (var-loc var)))
(t (var-kind var))))
(defun set-var (loc var &aux (var-loc (var-loc var))) ; ccb
(unless (and (consp loc)
(eq (car loc) 'VAR)
(eq (second loc) var)
; (eq (third loc) ccb)
)
(if (var-p var)
(case (var-kind var)
(LEXICAL (wt-nl)
(if (var-ref-ccb var)
(wt-env var-loc)
(wt-lex var-loc))
(wt "= " loc ";"))
(SPECIAL (wt-nl "(" var-loc "->symbol.dbind)= " loc ";"))
(LEXICAL
(wt-nl)
(if (var-ref-ccb var)
(wt-env var-loc)
(wt-lex var-loc))
(wt "= ")
(wt-coerce-loc (var-rep-type var) loc)
(wt #\;))
(SPECIAL
(wt-nl "(" var-loc "->symbol.dbind)= ")
(wt-coerce-loc (var-rep-type var) loc)
(wt #\;))
(GLOBAL
(if *safe-compile*
(wt-nl "cl_set(" var-loc "," loc ");")
(wt-nl "(" var-loc "->symbol.dbind)= " loc ";")))
(wt-nl "cl_set(" var-loc ",")
(wt-nl "(" var-loc "->symbol.dbind)= "))
(wt-coerce-loc (var-rep-type var) loc)
(wt ");"))
(t
(wt-nl) (wt-lcl var-loc) (wt "= ")
(case (var-kind var)
(FIXNUM (wt-fixnum-loc loc))
(CHARACTER (wt-character-loc loc))
(LONG-FLOAT (wt-long-float-loc loc))
(SHORT-FLOAT (wt-short-float-loc loc))
(OBJECT (wt-loc loc))
(t (baboon)))
(wt ";"))
)))
(wt-nl var-loc "= ")
(wt-coerce-loc (var-rep-type var) loc)
(wt #\;))
)
(baboon)))
(defun set-lex (loc lex)
(unless (and (consp loc)
(eq (car loc) 'LEX)
(equal (second loc) lex))
(wt-nl) (wt-lex lex) (wt "= " loc ";")))
(defun wt-lex (lex)
(if (consp lex)
(wt "lex" (car lex) "[" (cdr lex) "]")
@ -304,12 +305,12 @@
(unless (symbolp name)
(return-from c1setq1 (c1expr `(setf ,name ,form))))
(setq name1 (c1vref name))
(pushnew (car name1) (info-changed-vars info))
(pushnew (car name1) (info-referred-vars info))
(pushnew (car name1) (info-local-referred info))
(pushnew name1 (info-changed-vars info))
(pushnew name1 (info-referred-vars info))
(pushnew name1 (info-local-referred info))
(setq form1 (c1expr form))
(add-info info (second form1))
(setq type (type-and (var-type (car name1)) (info-type (second form1))))
(setq type (type-and (var-type name1) (info-type (second form1))))
(unless type
(cmpwarn "Type mismatch between ~s and ~s." name form)
(setq type T))
@ -321,11 +322,11 @@
(list 'SETQ info name1 form1)
)
(defun c2setq (vref form &aux (dest (cons 'VAR vref)))
(let ((*destination* dest)) (c2expr* form))
(defun c2setq (vref form)
(let ((*destination* vref)) (c2expr* form))
(if (eq (car form) 'LOCATION)
(c2location (third form))
(unwind-exit dest))
(unwind-exit vref))
)
(defun c1progv (args &aux symbols values (info (make-info)) forms)
@ -342,10 +343,10 @@
&aux (*unwind-exit* *unwind-exit*))
(let* ((*lcl* *lcl*)
(lcl (next-lcl))
(sym-loc (list 'LCL (next-lcl)))
(val-loc (list 'LCL (next-lcl))))
(sym-loc (make-lcl-var))
(val-loc (make-lcl-var)))
(wt-nl "{cl_object " sym-loc "," val-loc ";")
(wt-nl "bds_ptr ") (wt-lcl lcl) (wt "=bds_top;")
(wt-nl "bds_ptr " lcl "=bds_top;")
(push lcl *unwind-exit*)
(let ((*destination* sym-loc)) (c2expr* symbols))
@ -389,7 +390,7 @@
((endp l))
(let* ((vref (c1vref (car l)))
(form (c1expr (second l)))
(type (type-and (var-type (car vref))
(type (type-and (var-type vref)
(info-type (second form)))))
(unless (equal type (info-type (second form)))
(let ((info1 (copy-info (second form))))
@ -397,23 +398,18 @@
(setq form (list* (car form) info1 (cddr form)))))
(push vref vrefs)
(push form forms)
(push (car vref) (info-changed-vars info))
(push vref (info-changed-vars info))
(add-info info (cadar forms)))
)
(list 'PSETQ info (nreverse vrefs) (nreverse forms))
)
(defun var-referred-in-forms (var forms)
(case (var-kind var)
((LEXICAL REPLACED FIXNUM CHARACTER LONG-FLOAT SHORT-FLOAT OBJECT)
(dolist (form forms nil)
(when (member var (info-referred-vars (second form)))
(return-from var-referred-in-forms t))))
(t (dolist (form forms nil)
(when (or (member var (info-referred-vars (second form)))
(info-sp-change (second form)))
(return-from var-referred-in-forms t))))
))
(let ((check-specials (member (var-kind var) '(SPECIAL GLOBAL))))
(dolist (form forms nil)
(when (or (member var (info-referred-vars (second form)))
(and check-specials (info-sp-change (second form))))
(return-from var-referred-in-forms t)))))
(defun c2psetq (vrefs forms &aux (*lcl* *lcl*) (saves nil) (blocks 0))
;; similar to inline-args
@ -421,7 +417,7 @@
(forms forms (cdr forms))
(var) (form))
((null vrefs))
(setq var (caar vrefs)
(setq var (first vrefs)
form (car forms))
(if (or (var-changed-in-forms var (cdr forms))
(var-referred-in-forms var (cdr forms)))
@ -429,17 +425,17 @@
(LOCATION (push (cons var (third form)) saves))
(otherwise
(if (local var)
(let* ((kind (var-kind var))
(lcl (next-lcl))
(temp (list 'VAR (make-var :kind kind :loc lcl))))
(wt-nl "{" *volatile* (rep-type kind)) (wt-lcl lcl) (wt ";")
(let* ((rep-type (var-rep-type var))
(rep-type-name (rep-type-name rep-type))
(temp (make-lcl-var :rep-type rep-type)))
(wt-nl "{" *volatile* rep-type-name " " temp ";")
(incf blocks)
(let ((*destination* temp)) (c2expr* form))
(push (cons var temp) saves))
(let ((*destination* (list 'TEMP (next-temp))))
(let ((*destination* (make-temp-var)))
(c2expr* form)
(push (cons var *destination*) saves)))))
(let ((*destination* (cons 'VAR (car vrefs)))) (c2expr* form))))
(let ((*destination* var)) (c2expr* form))))
(dolist (save saves) (set-var (cdr save) (car save)))
(dotimes (i blocks) (wt "}"))
(unwind-exit nil)
@ -455,9 +451,3 @@
(put-sysprop 'PROGV 'C2 'c2progv)
(put-sysprop 'PSETQ 'c1 'c1psetq)
(put-sysprop 'PSETQ 'C2 'c2psetq)
(put-sysprop 'VAR 'SET-LOC 'set-var)
(put-sysprop 'VAR 'WT-LOC 'wt-var)
(put-sysprop 'LEX 'SET-LOC 'set-lex)
(put-sysprop 'LEX 'WT-LOC 'wt-lex)

1
src/cmp/defsys.lsp.in
View file

@ -34,6 +34,7 @@
(cmpvar () () ())
(cmpwt () () ())
(cmpmain () () ())
(cmpffi () () ())
(cmpcfg () () ())))
(sbt:defsystem

57
src/cmp/load.lsp.in
View file

@ -1,29 +1,30 @@
(load "@abs_srcdir@/cmpdefs")
(load "@abs_srcdir@/cmpmac")
(load "@abs_srcdir@/cmpinline")
(load "@abs_srcdir@/cmputil")
(load "@abs_srcdir@/cmptype")
(load "@abs_srcdir@/cmpbind")
(load "@abs_srcdir@/cmpblock")
(load "@abs_srcdir@/cmpcall")
(load "@abs_srcdir@/cmpcatch")
(load "@abs_srcdir@/cmpenv")
(load "@abs_srcdir@/cmpeval")
(load "@abs_srcdir@/cmpexit")
(load "@abs_srcdir@/cmpflet")
(load "@abs_srcdir@/cmpfun")
(load "@abs_srcdir@/cmpif")
(load "@abs_srcdir@/cmplam")
(load "@abs_srcdir@/cmplet")
(load "@abs_srcdir@/cmploc")
(load "@abs_srcdir@/cmpmap")
(load "@abs_srcdir@/cmpmulti")
(load "@abs_srcdir@/cmpspecial")
(load "@abs_srcdir@/cmptag")
(load "@abs_srcdir@/cmptop")
(load "@abs_srcdir@/cmpvar")
(load "@abs_srcdir@/cmpwt")
(load "@abs_srcdir@/cmpmain")
(load "@abs_srcdir@/sysfun")
(load "@abs_builddir@/cmpcfg.lsp")
(load "@abs_srcdir@/cmpdefs" :verbose nil)
(load "@abs_srcdir@/cmpmac" :verbose nil)
(load "@abs_srcdir@/cmpinline" :verbose nil)
(load "@abs_srcdir@/cmputil" :verbose nil)
(load "@abs_srcdir@/cmptype" :verbose nil)
(load "@abs_srcdir@/cmpbind" :verbose nil)
(load "@abs_srcdir@/cmpblock" :verbose nil)
(load "@abs_srcdir@/cmpcall" :verbose nil)
(load "@abs_srcdir@/cmpcatch" :verbose nil)
(load "@abs_srcdir@/cmpenv" :verbose nil)
(load "@abs_srcdir@/cmpeval" :verbose nil)
(load "@abs_srcdir@/cmpexit" :verbose nil)
(load "@abs_srcdir@/cmpflet" :verbose nil)
(load "@abs_srcdir@/cmpfun" :verbose nil)
(load "@abs_srcdir@/cmpif" :verbose nil)
(load "@abs_srcdir@/cmplam" :verbose nil)
(load "@abs_srcdir@/cmplet" :verbose nil)
(load "@abs_srcdir@/cmploc" :verbose nil)
(load "@abs_srcdir@/cmpmap" :verbose nil)
(load "@abs_srcdir@/cmpmulti" :verbose nil)
(load "@abs_srcdir@/cmpspecial" :verbose nil)
(load "@abs_srcdir@/cmptag" :verbose nil)
(load "@abs_srcdir@/cmptop" :verbose nil)
(load "@abs_srcdir@/cmpvar" :verbose nil)
(load "@abs_srcdir@/cmpwt" :verbose nil)
(load "@abs_srcdir@/cmpffi" :verbose nil)
(load "@abs_srcdir@/cmpmain" :verbose nil)
(load "@abs_srcdir@/sysfun" :verbose nil)
(load "@abs_builddir@/cmpcfg.lsp" :verbose nil)

158
src/cmp/sysfun.lsp
View file

@ -216,33 +216,33 @@
(STANDARD-CHAR-P (character) T nil t)
(GRAPHIC-CHAR-P (character) T nil t)
(ALPHA-CHAR-P (character) T nil t
:inline-always ((character) boolean nil nil "isalpha(#0)"))
:inline-always ((character) :bool nil nil "isalpha(#0)"))
(UPPER-CASE-P (character) T nil t
:inline-always ((character) boolean nil nil "isupper(#0)"))
:inline-always ((character) :bool nil nil "isupper(#0)"))
(LOWER-CASE-P (character) T nil t
:inline-always ((character) boolean nil nil "islower(#0)"))
:inline-always ((character) :bool nil nil "islower(#0)"))
(BOTH-CASE-P (character) T nil t
:inline-always ((character) boolean nil nil "(islower(#0)||isupper(#0))"))
:inline-always ((character) :bool nil nil "(islower(#0)||isupper(#0))"))
(DIGIT-CHAR-P (character *) T nil nil
:inline-always
((character) boolean nil nil "@0; ((#0) <= '9' && (#0) >= '0')"))
((character) :bool nil nil "@0; ((#0) <= '9' && (#0) >= '0')"))
(ALPHANUMERICP (character) T nil t
:inline-always ((character) boolean nil nil "isalnum(#0)"))
:inline-always ((character) :bool nil nil "isalnum(#0)"))
(CHARACTER (T) CHARACTER)
(CHAR= (character *) T nil t
:inline-always ((character character) boolean nil nil "(#0)==(#1)")
:inline-always ((t t) boolean nil nil "char_code(#0)==char_code(#1)"))
:inline-always ((character character) :bool nil nil "(#0)==(#1)")
:inline-always ((t t) :bool nil nil "char_code(#0)==char_code(#1)"))
(CHAR/= (character *) T nil t
:inline-always ((character character) boolean nil nil "(#0)!=(#1)")
:inline-always ((t t) boolean nil nil "char_code(#0)!=char_code(#1)"))
:inline-always ((character character) :bool nil nil "(#0)!=(#1)")
:inline-always ((t t) :bool nil nil "char_code(#0)!=char_code(#1)"))
(CHAR< (character *) T nil t
:inline-always ((character character) boolean nil nil "(#0)<(#1)"))
:inline-always ((character character) :bool nil nil "(#0)<(#1)"))
(CHAR> (character *) T nil t
:inline-always ((character character) boolean nil nil "(#0)>(#1)"))
:inline-always ((character character) :bool nil nil "(#0)>(#1)"))
(CHAR<= (character *) T nil t
:inline-always ((character character) boolean nil nil "(#0)<=(#1)"))
:inline-always ((character character) :bool nil nil "(#0)<=(#1)"))
(CHAR>= (character *) T nil t
:inline-always ((character character) boolean nil nil "(#0)>=(#1)"))
:inline-always ((character character) :bool nil nil "(#0)>=(#1)"))
(CHAR-EQUAL (character *) T nil t)
(CHAR-NOT-EQUAL (character *) T nil t)
(CHAR-LESSP (character *) T nil t)
@ -420,8 +420,8 @@
:inline-always ((t t) t nil t "CONS(#0,#1)"))
(TREE-EQUAL (T T *) T NIL T)
(ENDP (T) T NIL T
:inline-safe ((t) boolean nil nil "endp(#0)")
:inline-unsafe ((t) boolean nil nil "#0==Cnil"))
:inline-safe ((t) :bool nil nil "endp(#0)")
:inline-unsafe ((t) :bool nil nil "#0==Cnil"))
(LIST-LENGTH (T) T NIL NIL)
(NTH (T T) T NIL NIL
:inline-always ((t t) t nil nil "nth(fixint(#0),#1)")
@ -610,23 +610,23 @@
(REALPART (T) T)
(IMAGPART (T) T)
(= (T *) T NIL T
:inline-always ((t t) boolean nil nil "number_equalp(#0,#1)")
:inline-always ((fixnum-float fixnum-float) boolean nil nil "(#0)==(#1)"))
:inline-always ((t t) :bool nil nil "number_equalp(#0,#1)")
:inline-always ((fixnum-float fixnum-float) :bool nil nil "(#0)==(#1)"))
(/= (T *) T nil t
:inline-always ((t t) boolean nil nil "!number_equalp(#0,#1)")
:inline-always ((fixnum-float fixnum-float) boolean nil nil "(#0)!=(#1)"))
:inline-always ((t t) :bool nil nil "!number_equalp(#0,#1)")
:inline-always ((fixnum-float fixnum-float) :bool nil nil "(#0)!=(#1)"))
(< (T *) T nil t
:inline-always ((t t) boolean nil nil "number_compare(#0,#1)<0")
:inline-always ((fixnum-float fixnum-float) boolean nil nil "(#0)<(#1)"))
:inline-always ((t t) :bool nil nil "number_compare(#0,#1)<0")
:inline-always ((fixnum-float fixnum-float) :bool nil nil "(#0)<(#1)"))
(> (T *) T nil t
:inline-always ((t t) boolean nil nil "number_compare(#0,#1)>0")
:inline-always ((fixnum-float fixnum-float) boolean nil nil "(#0)>(#1)"))
:inline-always ((t t) :bool nil nil "number_compare(#0,#1)>0")
:inline-always ((fixnum-float fixnum-float) :bool nil nil "(#0)>(#1)"))
(<= (T *) T nil t
:inline-always ((t t) boolean nil nil "number_compare(#0,#1)<=0")
:inline-always ((fixnum-float fixnum-float) boolean nil nil "(#0)<=(#1)"))
:inline-always ((t t) :bool nil nil "number_compare(#0,#1)<=0")
:inline-always ((fixnum-float fixnum-float) :bool nil nil "(#0)<=(#1)"))
(>= (T *) T nil t
:inline-always ((t t) boolean nil nil "number_compare(#0,#1)>=0")
:inline-always ((fixnum-float fixnum-float) boolean nil nil "(#0)>=(#1)"))
:inline-always ((t t) :bool nil nil "number_compare(#0,#1)>=0")
:inline-always ((fixnum-float fixnum-float) :bool nil nil "(#0)>=(#1)"))
(MAX (T *) T NIL NIL
:inline-always ((t t) t nil nil "@01;(number_compare(#0,#1)>=0?#0:#1)")
:inline-always ((fixnum fixnum) fixnum nil nil "@01;(#0)>=(#1)?#0:#1"))
@ -641,24 +641,24 @@
(LOGEQV (*) T NIL NIL)
(BOOLE (T T T) T NIL NIL)
(LOGBITP (T T) T NIL T
:inline-always ((fixnum fixnum) boolean nil nil "(#1 >> #0) & 1"))
:inline-always ((fixnum fixnum) :bool nil nil "(#1 >> #0) & 1"))
(ASH (T T) T)
(LOGCOUNT (T) T)
(INTEGER-LENGTH (T) FIXNUM)
(si::BIT-ARRAY-OP nil T)
(ZEROP (T) T NIL T
:inline-always ((t) boolean nil nil "number_compare(MAKE_FIXNUM(0),#0)==0")
:inline-always ((fixnum-float) boolean nil nil "(#0)==0"))
:inline-always ((t) :bool nil nil "number_compare(MAKE_FIXNUM(0),#0)==0")
:inline-always ((fixnum-float) :bool nil nil "(#0)==0"))
(PLUSP (T) T NIL T
:inline-always ((t) boolean nil nil "number_compare(MAKE_FIXNUM(0),#0)<0")
:inline-always ((fixnum-float) boolean nil nil "(#0)>0"))
:inline-always ((t) :bool nil nil "number_compare(MAKE_FIXNUM(0),#0)<0")
:inline-always ((fixnum-float) :bool nil nil "(#0)>0"))
(MINUSP (T) T NIL T
:inline-always ((t) boolean nil nil "number_compare(MAKE_FIXNUM(0),#0)>0")
:inline-always ((fixnum-float) boolean nil nil "(#0)<0"))
:inline-always ((t) :bool nil nil "number_compare(MAKE_FIXNUM(0),#0)>0")
:inline-always ((fixnum-float) :bool nil nil "(#0)<0"))
(ODDP (T) T NIL T
:inline-always ((fixnum fixnum) boolean nil nil "(#0) & 1"))
:inline-always ((fixnum fixnum) :bool nil nil "(#0) & 1"))
(EVENP (T) T NIL T
:inline-always ((fixnum fixnum) boolean nil nil "~(#0) & 1"))
:inline-always ((fixnum fixnum) :bool nil nil "~(#0) & 1"))
(RANDOM (T *) T)
(MAKE-RANDOM-STATE (*) T)
(RANDOM-STATE-P (T) T NIL T)
@ -735,33 +735,33 @@
(HOST-NAMESTRING (T) STRING)
(ENOUGH-NAMESTRING (T *) STRING)
(NULL (T) T NIL T
:inline-always ((t) boolean nil nil "#0==Cnil"))
:inline-always ((t) :bool nil nil "#0==Cnil"))
(SYMBOLP (T) T NIL T
:inline-always ((t) boolean nil nil "SYMBOLP(#0)"))
:inline-always ((t) :bool nil nil "SYMBOLP(#0)"))
(ATOM (T) T NIL T
:inline-always ((t) boolean nil nil "ATOM(#0)"))
:inline-always ((t) :bool nil nil "ATOM(#0)"))
(CONSP (T) T NIL T
:inline-always ((t) boolean nil nil "CONSP(#0)"))
:inline-always ((t) :bool nil nil "CONSP(#0)"))
(LISTP (T) T NIL T
:inline-always ((t) boolean nil nil "@0;LISTP(#0)"))
:inline-always ((t) :bool nil nil "@0;LISTP(#0)"))
(NUMBERP (T) T NIL T
:inline-always ((t) boolean nil nil "numberp(#0)"))
:inline-always ((t) :bool nil nil "numberp(#0)"))
(INTEGERP (T) T NIL T
:inline-always ((t) boolean nil nil
:inline-always ((t) :bool nil nil
"@0;type_of(#0)==t_fixnum||type_of(#0)==t_bignum"))
(RATIONALP (T) T nil t)
(FLOATP (T) T NIL T
:inline-always ((t) boolean nil nil
:inline-always ((t) :bool nil nil
"@0;type_of(#0)==t_shortfloat||type_of(#0)==t_longfloat"))
(COMPLEXP (T) T NIL T)
(CHARACTERP (T) T NIL T
:inline-always ((t) boolean nil nil "CHARACTERP(#0)"))
:inline-always ((t) :bool nil nil "CHARACTERP(#0)"))
(STRINGP (T) T NIL T
:inline-always ((t) boolean nil nil "type_of(#0)==t_string"))
:inline-always ((t) :bool nil nil "type_of(#0)==t_string"))
(BIT-VECTOR-P (T) T NIL T
:inline-always ((t) boolean nil nil "(type_of(#0)==t_bitvector)"))
:inline-always ((t) :bool nil nil "(type_of(#0)==t_bitvector)"))
(VECTORP (T) T NIL T
:inline-always ((t) boolean nil nil
:inline-always ((t) :bool nil nil
"@0;type_of(#0)==t_vector||
type_of(#0)==t_string||
type_of(#0)==t_bitvector"))
@ -769,29 +769,33 @@ type_of(#0)==t_bitvector"))
(SIMPLE-BIT-VECTOR-P (T) T NIL T)
(SIMPLE-VECTOR-P (T) T NIL T)
(ARRAYP (T) T NIL T
:inline-always ((t) boolean nil nil "@0;ARRAYP(#0)"))
:inline-always ((t) :bool nil nil "@0;ARRAYP(#0)"))
(PACKAGEP (T) T NIL T)
(FUNCTIONP (T) T NIL T)
(COMPILED-FUNCTION-P (T) T NIL T)
(EQ (T T) T NIL T
:inline-always ((t t) boolean nil nil "(#0)==(#1)")
:inline-always ((fixnum fixnum) boolean nil nil "(#0)==(#1)"))
:inline-always ((t t) :bool nil nil "(#0)==(#1)")
:inline-always ((fixnum fixnum) :bool nil nil "(#0)==(#1)"))
(EQL (T T) T NIL T
:inline-always ((t t) boolean nil nil "eql(#0,#1)")
:inline-always ((character t) boolean nil nil ; Beppe
:inline-always ((t t) :bool nil nil "eql(#0,#1)")
:inline-always ((character t) :bool nil nil ; Beppe
"(CHARACTERP(#1) && (#0)==CHAR_CODE(#1))")
:inline-always ((t character) boolean nil nil ; Beppe
:inline-always ((t character) :bool nil nil ; Beppe
"(CHARACTERP(#0) && CHAR_CODE(#0)==(#1))")
:inline-always ((character character) boolean nil nil "(#0)==(#1)")
:inline-always ((fixnum fixnum) boolean nil nil "(#0)==(#1)"))
:inline-always ((character character) :bool nil nil "(#0)==(#1)")
:inline-always (((not (or complex bignum ratio float)) t) :bool nil nil
"(#0)==(#1)")
:inline-always ((t (not (or complex bignum ratio float))) :bool nil nil
"(#0)==(#1)")
:inline-always ((fixnum fixnum) :bool nil nil "(#0)==(#1)"))
(EQUAL (T T) T nil t
:inline-always ((t t) boolean nil nil "equal(#0,#1)")
:inline-always ((fixnum fixnum) boolean nil nil "(#0)==(#1)"))
:inline-always ((t t) :bool nil nil "equal(#0,#1)")
:inline-always ((fixnum fixnum) :bool nil nil "(#0)==(#1)"))
(EQUALP (T T) T NIL T
:inline-always ((t t) boolean nil nil "equalp(#0,#1)")
:inline-always ((fixnum fixnum) boolean nil nil "(#0)==(#1)"))
:inline-always ((t t) :bool nil nil "equalp(#0,#1)")
:inline-always ((fixnum fixnum) :bool nil nil "(#0)==(#1)"))
(NOT (T) T NIL T
:inline-always ((t) boolean nil nil "(#0)==Cnil"))
:inline-always ((t) :bool nil nil "(#0)==Cnil"))
; file print.d
(CLEAR-OUTPUT (*) T)
@ -811,7 +815,7 @@ type_of(#0)==t_bitvector"))
:inline-always ((t t) t t nil "print(#0,#1)")
:inline-always ((t) t t nil "print(#0,Cnil)"))
(PROBE-FILE (T) T NIL T
:inline-always ((t) boolean nil nil "(file_exists(#0))"))
:inline-always ((t) :bool nil nil "(si_file_kind(#0,Ct)!=Cnil)"))
(UNREAD-CHAR (T *) T)
(READ (*) T)
(READ-CHAR (*) T)
@ -846,7 +850,7 @@ type_of(#0)==t_bitvector"))
(FBOUNDP (symbol) T nil t)
(SYMBOL-VALUE (symbol) T)
(BOUNDP (symbol) T nil t
:inline-unsafe ((t) boolean nil nil "(#0)->symbol.dbind!=OBJNULL"))
:inline-unsafe ((t) :bool nil nil "(#0)->symbol.dbind!=OBJNULL"))
(MACRO-FUNCTION (symbol) T)
(SPECIAL-OPERATOR-P (symbol) T nil t)
@ -906,9 +910,9 @@ type_of(#0)==t_bitvector"))
:inline-unsafe ((t fixnum character) character t nil
"(#0)->string.self[#1]= #2"))
(STRING= (string string *) T nil t
:inline-always ((string string) boolean nil nil "string_eq(#0,#1)"))
:inline-always ((string string) :bool nil nil "string_eq(#0,#1)"))
(STRING-EQUAL (string string *) T nil t
:inline-always ((string string) boolean nil nil "string_equal(#0,#1)"))
:inline-always ((string string) :bool nil nil "string_equal(#0,#1)"))
(STRING< (string string *) T nil t)
(STRING> (string string *) T nil t)
(STRING<= (string string *) T nil t)
@ -942,7 +946,7 @@ type_of(#0)==t_bitvector"))
(si::STRUCTURE-SET (t t fixnum t) T nil nil
:inline-always ((t t fixnum t) t T nil "structure_set(#0,#1,#2,#3)"))
(SI::STRUCTUREP (T) T NIL T
:inline-always ((t) boolean nil nil "type_of(#0)==t_structure"))
:inline-always ((t) :bool nil nil "type_of(#0)==t_structure"))
(SI::STRUCTURE-SUBTYPE-P (T T) T NIL T)
(si::RPLACA-NTHCDR (T T T) nil T nil t)
(si::LIST-NTH (T T) T nil t)
@ -970,7 +974,7 @@ type_of(#0)==t_bitvector"))
(GENTEMP (*) symbol)
(SYMBOL-PACKAGE (symbol) T)
(KEYWORDP (T) T NIL T
; :inline-always ((t) boolean nil nil
; :inline-always ((t) :bool nil nil
; "@0;(type_of(#0)==t_symbol&&(#0)->symbol.hpack==keyword_package)")
)
(SI::PUT-F NIL (T T))
@ -1018,12 +1022,12 @@ type_of(#0)==t_bitvector"))
(shift<< nil nil nil NIL NIL
:inline-always ((fixnum fixnum) fixnum nil nil "((#0) << (#1))"))
(short-float-p nil nil nil T T
:inline-always ((t) boolean nil nil "type_of(#0)==t_shortfloat"))
:inline-always ((t) :bool nil nil "type_of(#0)==t_shortfloat"))
(long-float-p nil nil nil T T
:inline-always ((t) boolean nil nil "type_of(#0)==t_longfloat"))
:inline-always ((t) :bool nil nil "type_of(#0)==t_longfloat"))
(si:fixnump nil nil nil T T
:inline-always ((t) boolean nil nil "FIXNUMP(#0)")
:inline-always ((fixnum) boolean nil nil "1"))
:inline-always ((t) :bool nil nil "FIXNUMP(#0)")
:inline-always ((fixnum) :bool nil nil "1"))
(si::put-properties (*) nil T)
)) ; end of inlines
@ -1031,14 +1035,14 @@ type_of(#0)==t_bitvector"))
(mapcar #'(lambda (x) (apply #'defsysfun x)) '(
; file instance.c
(si::ALLOCATE-RAW-INSTANCE (t fixnum) T)
(si::INSTANCE-REF-SAFE (t fixnum) T nil nil)
(si::INSTANCE-REF (t fixnum) T nil nil
:inline-always ((standard-object fixnum) t nil nil
"(#0)->instance.slots[#1]"))
(si::INSTANCE-REF-SAFE (t fixnum) T nil nil
:inline-always ((t fixnum) t nil nil "instance_ref((#0),(#1))")
:inline-unsafe ((standard-object fixnum) t nil nil
"(#0)->instance.slots[#1]"))
(si::INSTANCE-SET (t fixnum t) T nil nil
:inline-always ((standard-object fixnum t) t t nil
:inline-unsafe ((t fixnum t) t t nil "instance_set((#0),(#1),(#2))")
:inline-unsafe ((standard-object fixnum t) t t nil
"(#0)->instance.slots[#1]=(#2)"))
(si::INSTANCE-CLASS (t) T nil nil
:inline-always ((standard-object) t nil nil "CLASS_OF(#0)"))
@ -1047,7 +1051,7 @@ type_of(#0)==t_bitvector"))
(si::UNBOUND nil T nil t
:inline-always (nil T nil nil "OBJNULL"))
(si::SL-BOUNDP (t) T nil t
:inline-always ((t) boolean nil nil "(#0)!=OBJNULL"))
:inline-always ((t) :bool nil nil "(#0)!=OBJNULL"))
(si::SL-MAKUNBOUND (t fixnum) T nil t)
; file gfun.c

34
src/compile.lsp.in
View file

@ -1,17 +1,30 @@
;;;
;;; Configuration file for the bootstrapping version of ECL
;;; This is the "makefile" file for building ECL. The purpose of this file is
;;; - Compile the core of the Common-Lisp library (lsp, clos)
;;; - Compile the compiler (cmp)
;;; - Build an executable
;;; This can be done in two ways:
;;; - Using interpreted code and the ECL_MIN minimal environment.
;;; - On a second stage, using the final ECL executable, to test it.
;;;
;;;
;;; * Ensure that we have the whole of Common-Lisp to compile
;;;
(load "bare.lsp")
;;;
;;; Dump documentation
;;; * Dump documentation
;;;
(load "@srcdir@/doc/help.lsp")
(si::dump-documentation "@abs_builddir@/help.doc")
#+stage1
(progn
(load "@srcdir@/doc/help.lsp")
(si::dump-documentation "@abs_builddir@/help.doc"))
;;;
;;; Trick to make names shorter
;;; * Trick to make names shorter in C files
;;;
(si::package-lock "CL" nil)
(rename-package "CL" "CL" '("COMMON-LISP" "LISP"))
;;;
@ -22,7 +35,7 @@
(load "lsp/defsys.lsp")
(proclaim '(optimize (safety 2) (space 3)))
(sbt::operate-on-system lsp :library)
#+dlopen
#+(and stage1 dlopen)
(progn
(sbt::operate-on-system lsp :shared-library)
(load "lsp"))
@ -32,7 +45,7 @@
;;;
;;; * Compile, load and link PCL based Common-Lisp Object System
;;;
#+WANTS-CLOS
#+CLOS
(progn
(load "clos/defsys.lsp")
(proclaim '(optimize (safety 2) (space 3)))
@ -44,7 +57,7 @@
;;;
;;; * Compile, load and link Common-Lisp to C compiler
;;;
#+WANTS-CMP
#+(or (not stage1) WANTS-CMP)
(progn
(load "cmp/defsys.lsp")
(proclaim '(optimize (safety 2) (space 3)))
@ -52,6 +65,9 @@
;(sbt::operate-on-system cmp :load)
)
(compiler::build-program "ecl" :lisp-files '(#+(and (not dlopen) WANTS-CMP) cmp))
(compiler::build-program
#+stage1 "ecl"
#-stage1 "ecl2"
:lisp-files '(#+(and (not dlopen) WANTS-CMP) cmp))
(quit)

13
src/configure vendored
View file

@ -852,6 +852,7 @@ Optional Packages:
--with-gmp=args Configure supplied GMP library with arguments.
--with-oldloop Use the old MIT LOOP macro.
--with-clos-streams Allow user defined stream objects.
--with-ffi Run-time foreign data manipulation.
--with-x use the X Window System
Some influential environment variables:
@ -1374,6 +1375,12 @@ if test "${with_clos_streams+set}" = set; then
withval="$with_clos_streams"
closstreams="yes"
fi;
# Check whether --with-ffi or --without-ffi was given.
if test "${with_ffi+set}" = set; then
withval="$with_ffi"
ffi="yes"
fi;
# Check whether --enable-cxx or --disable-cxx was given.
if test "${enable_cxx+set}" = set; then
enableval="$enable_cxx"
@ -4038,6 +4045,12 @@ if test "${closstreams}"; then
#define ECL_CLOS_STREAMS 1
_ACEOF
fi
if test "${ffi}"; then
cat >>confdefs.h <<\_ACEOF
#define ECL_FFI 1
_ACEOF
fi
if test "${locative}" ; then
EXTRA_OBJS="${EXTRA_OBJS} unify.o"

6
src/configure.in
View file

@ -84,6 +84,9 @@ AC_ARG_WITH(oldloop,
AC_ARG_WITH(clos-streams,
[--with-clos-streams Allow user defined stream objects.],
closstreams="yes")
AC_ARG_WITH(ffi,
[--with-ffi Run-time foreign data manipulation.],
ffi="yes")
AC_ARG_ENABLE(cxx,
[--enable-cxx Build ECL using C++ compiler],
usecxx=${enableval},usecxx="no")
@ -207,6 +210,9 @@ fi
if test "${closstreams}"; then
AC_DEFINE(ECL_CLOS_STREAMS)
fi
if test "${ffi}"; then
AC_DEFINE(ECL_FFI)
fi
if test "${locative}" ; then
EXTRA_OBJS="${EXTRA_OBJS} unify.o"
AC_DEFINE(LOCATIVE)

91
src/doc/devel.txi
View file

@ -1334,12 +1334,14 @@ There are several mechanism to integrate C code within @ecl{}.
The user can embed his/her own C code into Lisp source code. The
idea is quite simple: the specified C code is inserted in the intermediate
C code that is generated by the @ecl{} compiler. In the following example,
@code{Clines} and @code{defentry} are top-level macros specific
@code{Clines} and @code{defentry} are macros specific
to @ecl{}. The @code{Clines} macro form specifies the C code to be embedded,
in terms of strings, and the @code{defentry} form defines an entry
of the specified C function from @ecl{}.
@lisp
(use-package "FFI")
(Clines
" int tak(x, y, z) "
" int x, y, z; "
@ -1350,7 +1352,7 @@ of the specified C function from @ecl{}.
" @} "
)
(defentry tak (int int int) (int "tak"))
(defentry tak (:int :int :int) (:int "tak"))
@end lisp
@node Embedding C code, , The C language interface, The compiler
@ -1364,18 +1366,21 @@ consists of C-language function definitions. The first C-language function in
the c-file is the ``initializer'', which is executed when the fasl file is
loaded, and the other C-language functions are the C versions of the Lisp
functions (including macro expansion functions) defined in the source file. By
using the top-level macros @code{Clines} and @code{defCfun} described below,
using the macro @code{Clines} defined below,
the user can direct the compiler to insert his or her own C-language function
definitions and/or C-language preprocessor macros such as @code{#define} and
@code{#include} into the c-file. In order that such C-language functions be
invoked from @ecl{}, another top-level macro @code{defentry} is used. This
macro defines a Lisp function whose body consists of the calling sequence to
the specified C-language function.
invoked from @ecl{}, another form @code{c-inline} is used. This form
defines a piece of C/C++ code that receives arguments from the lisp
world and outputs some value. For simplicity, a macro called
@code{defentry} is provided which uses @code{c-inline} to write Lisp
wrapping functions whose body consists of the calling sequence to
a specified C-language function.
The C-language function definitions are placed in the c-file in the order of
the corresponding Lisp functions defined in the source file. That is, the C
code for the first Lisp function comes first, the C code for the second Lisp
function comes second, and so on. If a @code{Clines} or @code{defCfun} macro
function comes second, and so on. If a @code{Clines} macro
form appears between two Lisp function definitions in the source file, then the
C code specified by the macro is placed in between the C code for the Lisp
functions.
@ -1385,11 +1390,11 @@ We define some terminology here which is used throughout this Chapter. A
identifier, or a Lisp symbol whose print-name, with all its alphabetic
characters turned into lower case, is a valid C identifier. Thus the symbol
@code{foo} is equivalent to the string @code{"foo"} when used as a C-id.
Similarly, a @emph{C-expr} is a string or a symbol that may be regarded as a
C-language expression. A @emph{C-type} is one of the Lisp symbols @code{int,
char, float, double,} and @code{object}. Each corresponds to a data type in
the C language; @code{object} is the type of Lisp object and other C-types are
primitive data types in C.
Similarly, a @emph{C-expr} is a string that may be regarded as a
C-language expression. A @emph{C-type} is one of the Lisp symbols
@code{:int, :char, :float, :double,...} and @code{:object}.
Each corresponds to a data type in the C language; @code{:object} is
the type of Lisp object and other C-types are primitive data types in C.
@defmac {Clines} {@{string@}*}
When the @ecl{} compiler encounters a macro form @code{(Clines @var{string1
@ -1408,7 +1413,51 @@ When interpreted, a @code{Clines} macro form expands to @nil{}.
@end defmac
@defmac {defentry} {function parameter-list C-function}
@defmac {c-inline} {@var{args-list} @var{arg-C-types} @var{output-C-type} @var{C-expr} @keys{} (@var{side-effects} @code{T}) (@var{one-liner} @code{T})}
@code{c-inline} is a special form that can only be used in compiled code.
For all purposes it behaves as a Lisp form, which takes the arguments
given in @var{args-list} and produces a single value. Behind the curtains,
the arguments of @var{args-list} (which can be any valid Lisp form)
are coerced to the the C types given in @var{arg-C-types}, passed to
the C expression @var{C-expr}, and coerced back to Lisp using the
C type @var{output-C-type} as a guide.
@var{C-expr} is a string containing C code and maybe some special escape codes.
First, the arguments of the form may be retrieved as @code{#0}, @code{#1}, etc.
Second, if the @code{c-inline} form is a one-line C expression (That is,
@var{one-liner} is true), then the whole expression is interpreted as the
output value. But if the code, on the other hand, is a multiline expression
(@var{one-liner} is false), the form has to be output using @code{@@(return)
=...}. Finally, Lisp constants may be used in the C code making use of the
prefix @code{@@}.
@example
(use-package "FFI")
(Clines "
#include <math.h>
double foo (double x, double y) @{
return sinh(x) * y;
@}")
(defvar *a*
(c-inline (1.23) (:double) :double
"foo(#0,1.44)"
:side-effects nil
:one-liner t))
(defvar *b*
(c-inline (1.23) (:double) :double
"@{cl_object x = symbol_value(@@*a*);
@@(return) = foo(#0,object_to_float(x));@}"
:side-effects nil
:one-liner nil))
@end example
@end defmac
@defmac {defentry} {@var{function} @var{parameter-list} @var{C-function}}
@code{defentry} defines a Lisp function whose body consists of the calling
sequence to a C-language function. @var{function} is the name of the Lisp
@ -1425,7 +1474,7 @@ is called.
@end defmac
@example
(defentry tak (int int int) (int tak))
(defentry tak (:int :int :int) (:int tak))
@end example
The Lisp function @code{tak} defined by this @code{defentry} form requires
@ -1452,7 +1501,9 @@ single Lisp source file; one in the C language and the other in Lisp.
Suppose you have a Lisp source file whose contents are:
@example
@example
(use-package "FFI")
;;; C version of TAK.
(Clines "
@ -1467,7 +1518,7 @@ Suppose you have a Lisp source file whose contents are:
)
;;; TAK calls the C function tak defined above.
(defentry tak (int int int) (int tak))
(defentry tak (:int :int :int) (:int tak))
;;; The alternative Lisp definition of TAK.
(defla tak (x y z)
(if (>= y x)
@ -1487,8 +1538,8 @@ The @ecl{} compiler produces a function named @var{name} with as many
arguments as @var{arg-types}. The @var{C-expr} is an arbitrary C expression
where the arguments to the function are denoted by @code{#@emph{i}}, where
@code{@emph{i}} is the integer corresponding to the argument position. The
@var{args-types} is the list of \clisp types of the arguments to the function,
while @var{result-type} is the \clisp type of the result. The actual arguments
@var{args-types} is the list of @clisp types of the arguments to the function,
while @var{result-type} is the @clisp type of the result. The actual arguments
are coerced to the required types before executing the @var{C-expr} and the
result is converted into a Lisp object. @code{defCbody} is ignored by the
interpreter.
@ -1550,9 +1601,9 @@ definline-form:
(defCbody symbol (@{type@}*) type C-expr)
C-function-name:
C-expr:
@{ string | symbol @}
C-expr:
string
C-type:
@{ object | int | char | float | double @}
@end example

3
src/h/config.h.in
View file

@ -28,6 +28,9 @@
/* Network streams */
#undef TCP
/* Foreign functions interface */
#undef ECL_FFI
/*
* C TYPES AND SYSTEM LIMITS
*/

16
src/h/external.h
View file

@ -74,7 +74,6 @@ extern cl_symbol_initializer cl_symbols[];
extern cl_index cl_num_symbols_in_core;
extern void init_all_symbols(void);
/* apply.c */
extern cl_object APPLY_fixed(int n, cl_object (*f)(), cl_object *x);
@ -335,6 +334,15 @@ extern cl_object link_call(cl_object sym, cl_objectfn *pLK, int narg, cl_va_list
extern cl_object cl_safe_eval(cl_object form, cl_object *bytecodes, cl_object env, cl_object err_value);
extern void init_eval(void);
/* ffi.c */
#ifdef ECL_FFI
extern cl_object si_allocate_foreign_data(cl_object tag, cl_object size);
extern cl_object si_free_foreign_data(cl_object x);
extern cl_object si_foreign_data_tag(cl_object x);
extern cl_object ecl_make_foreign_data(cl_object tag, cl_index size, void *data);
#endif
/* file.c */
extern cl_object cl_make_synonym_stream(cl_object sym);
@ -1316,17 +1324,15 @@ extern cl_object cl_delete_file(cl_object file);
extern cl_object cl_probe_file(cl_object file);
extern cl_object cl_file_write_date(cl_object file);
extern cl_object cl_file_author(cl_object file);
extern cl_object si_file_kind(cl_object pathname, cl_object follow_links);
extern cl_object si_chdir(cl_object directory);
extern cl_object si_mkdir(cl_object directory, cl_object mode);
extern cl_object si_string_match(cl_object string, cl_object pattern);
extern cl_object cl_directory _ARGS((int narg, cl_object directory, ...));
extern cl_object cl_user_homedir_pathname _ARGS((int narg, ...));
extern cl_object cl_directory _ARGS((int narg, ...));
extern cl_object si_file_exists (cl_object pathname);
extern cl_object si_mkstemp(cl_object template);
extern const char *expand_pathname(const char *name);
extern cl_object string_to_pathname(char *s);
extern bool file_exists(cl_object file);
extern FILE *backup_fopen(const char *filename, const char *option);
extern int file_len(FILE *fp);
extern cl_object homedir_pathname(cl_object user);

16
src/h/object.h
View file

@ -378,6 +378,16 @@ struct cclosure { /* compiled closure header */
cl_objectfn entry; /* entry address */
cl_object block; /* descriptor of C code block for GC */
};
#ifdef ECL_FFI
struct foreign { /* user defined datatype */
HEADER;
cl_object tag; /* a tag identifying the type */
cl_index size; /* the amount of memory allocated */
char *data; /* the data itself */
};
#endif
/*
dummy type
*/
@ -469,6 +479,9 @@ union lispunion {
struct thread thread; /* thread */
#endif /* THREADS */
struct codeblock cblock; /* codeblock */
#ifdef ECL_FFI
struct foreign foreign; /* user defined data type */
#endif
};
/*
@ -509,6 +522,9 @@ typedef enum {
t_thread, /* 20 19 */
#endif
t_codeblock, /* 21 20 */
#ifdef ECL_FFI
t_foreign, /* 22 21 */
#endif
t_end,
t_other,
t_contiguous, /* contiguous block */

1
src/lsp/autoload.lsp
View file

@ -282,7 +282,6 @@ NIL, then all packages are searched."
(defstruct 1)
(deftype 2)
(defun 2)
(defunC 2) ; Beppe
(do 2)
(do* 2)
(do-symbols 1)

112
src/lsp/ffi-objects.lsp Normal file
View file

@ -0,0 +1,112 @@
;;;; Copyright (c) 2001, Juan Jose Garcia-Ripoll
;;;;
;;;; This program is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Library General Public
;;;; License as published by the Free Software Foundation; either
;;;; version 2 of the License, or (at your option) any later version.
;;;;
;;;; See file '../Copyright' for full details.
;;;; Routines to handle foreign objects, structures, arrays, etc.
(in-package "FFI")
;; ----------------------------------------------------------------------
;; OPERATIONS WITH FOREIGN TYPES
;;
(defmacro def-foreign-type (name type)
`(si::set-sysprop ',name 'FOREIGN-TYPE ',type))
(defun basic-foreign-type-size (type)
(case type
((:unsigned-char :char :byte :unsigned-byte) 1)
((:short :unsigned-short) 2)
((:int :unsigned-int) 4)
((:long :unsigned-long) 4)
((:float) 4)
((:double) 8)
((:pointer-void) 4)
(:void 0)
(t (error-foreign-type type))))
(defun error-foreign-type (type)
(error 'simple-type-error
:format-control "~S is not a valid foreign type"
:format-args (list type)
:datum type
:expected-type 'FOREIGN-TYPE))
(defun compute-foreign-type-size (type &aux name args)
(if (symbolp type)
(if (setq args (si::get-sysprop type 'FOREIGN-TYPE))
(compute-foreign-type-size type)
(basic-foreign-type-size type))
(case (first type)
(* (basic-foreign-type-size :pointer-void))
(:struct
(reduce #'+ (rest type) :key #'second :initial-value 0))
(:union
(reduce #'max (rest type) :initial-value 0))
(:enum
(basic-foreign-type-size :int))
(:array
(let ((elt-type-size (compute-foreign-type-size (second type))))
(unless (integerp (third type))
(error-foreign-type type))
(* elt-type-size (third type)))))))
;; ----------------------------------------------------------------------
;; ENUMERATIONS
;;
(defmacro def-enum (enum-name &optional keys &key (separator-string "#"))
(let ((counter 0)
(output '())
(name))
(dolist (i keys)
(cond ((symbolp i) (setq name i))
((listp i) (setq name (first i) counter (second i))))
(unless (and (symbolp name) (integerp counter))
(error "~S is not a valid enumeration key" (list name counter)))
(setq name (intern (concatenate 'string
(symbol-name enum-name)
separator-string
(symbol-name name))))
(push (list name counter) output)
(incf counter))
`(progn
(def-foreign-type ,enum-name (ENUM ,@output))
,@(mapcar #'(lambda (x) (cons 'DEFCONSTANT x)) output))))
;; ----------------------------------------------------------------------
;; ARRAYS
;;
(defmacro def-array (name elt-type)
`(def-foreign-type ,name (:array ,elt-type)))
;; ----------------------------------------------------------------------
;; UTILITIES
;;
(defun null-char-p (char)
(or (eql char 0)
(eql char (code-char 0))))
(defun ensure-char-character (char)
(cond ((integerp char)
(code-char char))
((characterp char)
char)
(t
(error 'simple-type-error :datum char :expected-type 'character))))
(defun ensure-char-integer (char)
(cond ((integerp char)
char)
((characterp char)
(char-code char))
(t
(error 'simple-type-error :datum char :expected-type 'character))))

26
src/lsp/ffi.lsp
View file

@ -10,20 +10,18 @@
;;;; FFI Symbols used in the foreign function interface
(defpackage "FFI"
(:export clines
defcfun
defentry
defla
defcbody ; Beppe
definline ; Beppe
defunC ; Beppe
void
object
char* ; Beppe
;;char
int
;;float
double
(:export "CLINES" "DEFCFUN" "DEFENTRY" "DEFLA" "DEFCBODY"
"DEFINLINE" "DEFUNC" "C-INLINE"
"VOID" "OBJECT" "CHAR*" "INT" "DOUBLE"
"DEF-CONSTANT" "DEF-FOREIGN-TYPE" "DEF-ENUM" "DEF-STRUCT"
"DEF-ARRAY-POINTER" "DEF-FUNCTION" "DEF-UNION" "DEF-ARRAY"
"ALLOCATE-FOREIGN-OBJECT" "FREE-FOREIGN-OBJECT" "MAKE-NULL-POINTER"
"GET-SLOT-VALUE" "GET-SLOT-POINTER" "DEREF-ARRAY" "DEREF-POINTER"
"POINTER-ADDRESS" "SIZE-OF-FOREIGN-TYPE"
"NULL-CHAR-P" "ENSURE-CHAR-CHARACTER" "ENSURE-CHAR-INTEGER"
"NULL-POINTER-P" "+NULL-CSTRING-POINTER+"
))
(in-package "FFI")

2
src/lsp/load.lsp.in
View file

@ -26,6 +26,8 @@
(load "@abs_srcdir@/loop2.lsp" :verbose t)
(load "@abs_srcdir@/defpackage.lsp" :verbose t)
(load "@abs_srcdir@/ffi.lsp" :verbose t)
#+ffi
(load "@abs_srcdir@/ffi-objects.lsp" :verbose t)
#+threads
(load "@abs_srcdir@/thread.lsp" :verbose t)
#+tk

8
src/lsp/mislib.lsp
View file

@ -138,11 +138,9 @@ Sunday is the *last* day of the week!!"
(let* (d)
(dolist (item (pathname-directory a-pathname))
(setf d (nconc d (list item)))
(let ((p (make-pathname :directory d :name nil :type nil :version nil
:host (pathname-host a-pathname)
:device (pathname-device a-pathname))))
(unless (si::file-exists p)
(si::mkdir p #o777)))))))
(let ((p (make-pathname :directory d :default a-pathname)))
(unless (or (symbolp item) (si::file-kind p nil))
(si::mkdir p #o777))))))
(defmacro with-hash-table-iterator ((iterator package) &body body)
`(let ((,iterator (hash-table-iterator ,package)))

10
src/lsp/predlib.lsp
View file

@ -953,8 +953,8 @@ if not possible."
(let ((tag (canonical-type type))
(out))
(setq tag (canonical-type type))
(print-types-database *elementary-types*)
(print-types-database *member-types*)
;(print-types-database *elementary-types*)
;(print-types-database *member-types*)
(dolist (i *member-types*)
(unless (zerop (logand (cdr i) tag))
(push (car i) out)))
@ -962,7 +962,7 @@ if not possible."
(setq out `((MEMBER ,@out))))
(dolist (i *elementary-types*)
(unless (zerop (logand (cdr i) tag))
(print (list tag (cdr i) (logand tag (cdr i))))
;(print (list tag (cdr i) (logand tag (cdr i))))
(push (car i) out)))
(values tag `(OR ,@out)))))
@ -1076,13 +1076,13 @@ if not possible."
(setq tag (new-type-tag))
(unless (eq strict-supertype 't)
(extend-type-tag tag strict-supertype-tag))))
(push (let ((*print-base* 2)) (print (cons type tag))) *elementary-types*)
(push (let ((*print-base* 2)) (cons type tag)) *elementary-types*)
))
#+nil
(let ((tag (new-type-tag)))
(extend-type-tag tag (canonical-type 'symbol))
(setq *member-types* (acons 'NIL tag *member-types*))
(push (cons 'NULL tag) *elementary-types*))
(print-types-database *elementary-types*)
;(print-types-database *elementary-types*)
(format t "~%~70B" *highest-type-tag*)
); ngorp

3
src/lsp/seqlib.lsp
View file

@ -57,8 +57,7 @@
start end))
(values x0 x1)))
#+ecl-min
(eval-when (compile eval)
(eval-when (compile #+ecl-min eval)
(defmacro with-start-end (start end seq &body body)
`(multiple-value-bind (,start ,end)
(sequence-limits ,start ,end ,seq)

1
src/lsp/setf.lsp
View file

@ -331,7 +331,6 @@ Does not check if the third gang is a single-element list."
(cons (setf-expand-1 (car l) (cadr l) env)
(setf-expand (cddr l) env)))))
;;; SETF macro.
(defmacro setf (&environment env &rest rest)
"Syntax: (setf {place form}*)

19
src/lsp/top.lsp
View file

@ -399,10 +399,14 @@ value of this variable is non-NIL.")
(load (argv i))))
((string= "-shell" (argv i))
(incf i)
(if (= i argc)
(error "Missing file name")
(let ((*load-verbose* nil))
(load (argv i))))
#-ecl-min
(let ((*break-enable* nil))
(handler-case
(if (= i argc)
(format t "Missing file name")
(let ((*load-verbose* nil))
(load (argv i))))
(condition (c) (format t "~A" c))))
(quit))
((string= "-eval" (argv i))
(incf i)
@ -486,7 +490,7 @@ file. When the saved image is invoked, it will start the redefined top-level."
(eval-with-env - *break-env*)))
(setq /// // // / / values *** ** ** * * (car /))
(tpl-print values)
nil)
nil))
(break-where)))))
(defun tpl-prompt ()
@ -498,7 +502,7 @@ file. When the saved image is invoked, it will start the redefined top-level."
(- *tpl-level* *step-level* -1)
""))
(defun tpl-read ()
(defun tpl-read (&aux (*readtable* (sys::standard-readtable)))
(finish-output)
(loop
(case (peek-char nil *standard-input* nil :EOF)
@ -530,7 +534,7 @@ file. When the saved image is invoked, it will start the redefined top-level."
;; error happens within the reader, and we perform a ":C" or
;; (CONTINUE), the reader will wait for an inexistent #\Newline.
(t
(return (read-preserving-whitespace))))))
(return (read))))))
(defun tpl-make-command (name line &aux (c nil))
(dolist (commands *tpl-commands*)
@ -630,6 +634,7 @@ file. When the saved image is invoked, it will start the redefined top-level."
(let*((*print-level* 2)
(*print-length* 4)
(*print-pretty* t)
(*print-readably* nil)
(functions) (blocks) (variables))
(do* ((env *break-env* (cddr env))
(type (first env) (first env))

3
src/util/emacs.el
View file

@ -281,6 +281,8 @@
"lsp/top.lsp"
"lsp/trace.lsp"
"lsp/util.lsp"
"lsp/ffi.lsp"
"lsp/ffi-objects.lsp"
"clos/boot.lsp"
"clos/builtin.lsp"
"clos/change.lsp"
@ -309,6 +311,7 @@
"cmp/cmpenv.lsp"
"cmp/cmpeval.lsp"
"cmp/cmpexit.lsp"
"cmp/cmpffi.lsp"
"cmp/cmpflet.lsp"
"cmp/cmpfun.lsp"
"cmp/cmpif.lsp"