diff --git a/src/CHANGELOG b/src/CHANGELOG index ed507bac6..8f78a364f 100644 --- a/src/CHANGELOG +++ b/src/CHANGELOG @@ -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: ===== diff --git a/src/Makefile.in b/src/Makefile.in index 4f8fa27b6..c2ed7db62 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -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 diff --git a/src/bare.lsp.in b/src/bare.lsp.in index ac193091a..c867cc9a2 100644 --- a/src/bare.lsp.in +++ b/src/bare.lsp.in @@ -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*))) diff --git a/src/c/Makefile.in b/src/c/Makefile.in index b1e8434f5..d104f405b 100644 --- a/src/c/Makefile.in +++ b/src/c/Makefile.in @@ -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 diff --git a/src/c/alloc.d b/src/c/alloc.d index 22c25223f..e4985ec86 100644 --- a/src/c/alloc.d +++ b/src/c/alloc.d @@ -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); diff --git a/src/c/alloc_2.d b/src/c/alloc_2.d index e1b5c2b5a..f1465127b 100644 --- a/src/c/alloc_2.d +++ b/src/c/alloc_2.d @@ -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)); diff --git a/src/c/compiler.d b/src/c/compiler.d index aa612d2b2..a9bf0de11 100644 --- a/src/c/compiler.d +++ b/src/c/compiler.d @@ -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); diff --git a/src/c/dpp.c b/src/c/dpp.c index 05fc90cec..5ca676b76 100644 --- a/src/c/dpp.c +++ b/src/c/dpp.c @@ -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++) { diff --git a/src/c/ffi.d b/src/c/ffi.d new file mode 100644 index 000000000..3c6304fb0 --- /dev/null +++ b/src/c/ffi.d @@ -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 */ diff --git a/src/c/file.d b/src/c/file.d index a0b4e4874..98ebab589 100644 --- a/src/c/file.d +++ b/src/c/file.d @@ -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); diff --git a/src/c/gbc.d b/src/c/gbc.d index ea9426883..489f9cb05 100644 --- a/src/c/gbc.d +++ b/src/c/gbc.d @@ -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)); diff --git a/src/c/instance.d b/src/c/instance.d index 7c7bde5b1..b8178ad39 100644 --- a/src/c/instance.d +++ b/src/c/instance.d @@ -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 diff --git a/src/c/load.d b/src/c/load.d index 717db3298..c767b0207 100644 --- a/src/c/load.d +++ b/src/c/load.d @@ -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; diff --git a/src/c/main.d b/src/c/main.d index cbd8ed070..223a5d9d4 100644 --- a/src/c/main.d +++ b/src/c/main.d @@ -259,6 +259,10 @@ init_main(void) ADD_FEATURE("PDE"); #endif +#ifdef ECL_FFI + ADD_FEATURE("FFI"); +#endif + #ifdef unix ADD_FEATURE("UNIX"); #endif diff --git a/src/c/pathname.d b/src/c/pathname.d index db890ce4c..ebf204c7d 100644 --- a/src/c/pathname.d +++ b/src/c/pathname.d @@ -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); diff --git a/src/c/print.d b/src/c/print.d index ee9d647b1..91ba44b5d 100644 --- a/src/c/print.d +++ b/src/c/print.d @@ -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("#'); break; #endif /* CLOS */ +#ifdef ECL_FFI + case t_foreign: + if (PRINTreadably) FEprint_not_readable(x); + write_str("#foreign.tag, level);*/ + write_addr(x->foreign.data); + write_ch('>'); + break; +#endif /* ECL_FFI */ default: if (PRINTreadably) FEprint_not_readable(x); write_str("# #include #include "ecl.h" +#include "ecl-inl.h" #include "machines.h" #ifdef BSD #include @@ -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 , 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) } diff --git a/src/clos/print.lsp b/src/clos/print.lsp index 35954c1a1..01a04abf2 100644 --- a/src/clos/print.lsp +++ b/src/clos/print.lsp @@ -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) diff --git a/src/cmp/cmpbind.lsp b/src/cmp/cmpbind.lsp index 730687ebd..69404a08b 100644 --- a/src/cmp/cmpbind.lsp +++ b/src/cmp/cmpbind.lsp @@ -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. diff --git a/src/cmp/cmpblock.lsp b/src/cmp/cmpblock.lsp index 87424aac5..8c36a9fad 100644 --- a/src/cmp/cmpblock.lsp +++ b/src/cmp/cmpblock.lsp @@ -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*) diff --git a/src/cmp/cmpcall.lsp b/src/cmp/cmpcall.lsp index f51d6b891..a36c25891 100644 --- a/src/cmp/cmpcall.lsp +++ b/src/cmp/cmpcall.lsp @@ -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)) diff --git a/src/cmp/cmpcatch.lsp b/src/cmp/cmpcatch.lsp index 216247e7f..a2a73010c 100644 --- a/src/cmp/cmpcatch.lsp +++ b/src/cmp/cmpcatch.lsp @@ -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 ");")) diff --git a/src/cmp/cmpdefs.lsp b/src/cmp/cmpdefs.lsp index c08fe693e..a0ce190c8 100644 --- a/src/cmp/cmpdefs.lsp +++ b/src/cmp/cmpdefs.lsp @@ -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) diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp index be249649a..3daa40d63 100644 --- a/src/cmp/cmpenv.lsp +++ b/src/cmp/cmpenv.lsp @@ -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*) diff --git a/src/cmp/cmpeval.lsp b/src/cmp/cmpeval.lsp index d2ead0241..c51729db7 100644 --- a/src/cmp/cmpeval.lsp +++ b/src/cmp/cmpeval.lsp @@ -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) diff --git a/src/cmp/cmpexit.lsp b/src/cmp/cmpexit.lsp index f7af9f5e4..9932df08b 100644 --- a/src/cmp/cmpexit.lsp +++ b/src/cmp/cmpexit.lsp @@ -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 ) diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp new file mode 100644 index 000000000..6a7bcff05 --- /dev/null +++ b/src/cmp/cmpffi.lsp @@ -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) diff --git a/src/cmp/cmpflet.lsp b/src/cmp/cmpflet.lsp index de813cd4e..916580d18 100644 --- a/src/cmp/cmpflet.lsp +++ b/src/cmp/cmpflet.lsp @@ -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) diff --git a/src/cmp/cmpfun.lsp b/src/cmp/cmpfun.lsp index 1a5023201..eca3f86a5 100644 --- a/src/cmp/cmpfun.lsp +++ b/src/cmp/cmpfun.lsp @@ -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) diff --git a/src/cmp/cmpif.lsp b/src/cmp/cmpif.lsp index 81f6b94e2..15fbf74d8 100644 --- a/src/cmp/cmpif.lsp +++ b/src/cmp/cmpif.lsp @@ -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) diff --git a/src/cmp/cmpinline.lsp b/src/cmp/cmpinline.lsp index 1083f74c5..de5c5876c 100644 --- a/src/cmp/cmpinline.lsp +++ b/src/cmp/cmpinline.lsp @@ -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) diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp index 9d124d852..7b5464fe3 100644 --- a/src/cmp/cmplam.lsp +++ b/src/cmp/cmplam.lsp @@ -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 "}") diff --git a/src/cmp/cmplet.lsp b/src/cmp/cmplet.lsp index 6e83aa95c..53c4f643c 100644 --- a/src/cmp/cmplet.lsp +++ b/src/cmp/cmplet.lsp @@ -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))))) diff --git a/src/cmp/cmploc.lsp b/src/cmp/cmploc.lsp index 914b31ade..98b7269dc 100644 --- a/src/cmp/cmploc.lsp +++ b/src/cmp/cmploc.lsp @@ -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) diff --git a/src/cmp/cmpmain.lsp b/src/cmp/cmpmain.lsp index bb761bd0e..78ac73124 100644 --- a/src/cmp/cmpmain.lsp +++ b/src/cmp/cmpmain.lsp @@ -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)) diff --git a/src/cmp/cmpmap.lsp b/src/cmp/cmpmap.lsp index dd82ce835..bf9e693be 100644 --- a/src/cmp/cmpmap.lsp +++ b/src/cmp/cmpmap.lsp @@ -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)))) diff --git a/src/cmp/cmpmulti.lsp b/src/cmp/cmpmulti.lsp index 71b6a7f45..e0390edd4 100644 --- a/src/cmp/cmpmulti.lsp +++ b/src/cmp/cmpmulti.lsp @@ -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)))))) diff --git a/src/cmp/cmpspecial.lsp b/src/cmp/cmpspecial.lsp index ce6c5280e..33096f542 100644 --- a/src/cmp/cmpspecial.lsp +++ b/src/cmp/cmpspecial.lsp @@ -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)))) diff --git a/src/cmp/cmptag.lsp b/src/cmp/cmptag.lsp index bdbe3e431..833508a7f 100644 --- a/src/cmp/cmptag.lsp +++ b/src/cmp/cmptag.lsp @@ -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 diff --git a/src/cmp/cmptop.lsp b/src/cmp/cmptop.lsp index 87e298520..dff3f501a 100644 --- a/src/cmp/cmptop.lsp +++ b/src/cmp/cmptop.lsp @@ -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) diff --git a/src/cmp/cmputil.lsp b/src/cmp/cmputil.lsp index 88778c105..d42a7734c 100644 --- a/src/cmp/cmputil.lsp +++ b/src/cmp/cmputil.lsp @@ -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*) diff --git a/src/cmp/cmpvar.lsp b/src/cmp/cmpvar.lsp index 4636dd8d7..3177fe394 100644 --- a/src/cmp/cmpvar.lsp +++ b/src/cmp/cmpvar.lsp @@ -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) diff --git a/src/cmp/defsys.lsp.in b/src/cmp/defsys.lsp.in index 4c3670abc..1f95d30b9 100644 --- a/src/cmp/defsys.lsp.in +++ b/src/cmp/defsys.lsp.in @@ -34,6 +34,7 @@ (cmpvar () () ()) (cmpwt () () ()) (cmpmain () () ()) + (cmpffi () () ()) (cmpcfg () () ()))) (sbt:defsystem diff --git a/src/cmp/load.lsp.in b/src/cmp/load.lsp.in index ec6c01704..0aae47fad 100644 --- a/src/cmp/load.lsp.in +++ b/src/cmp/load.lsp.in @@ -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) diff --git a/src/cmp/sysfun.lsp b/src/cmp/sysfun.lsp index 7f3f563af..f01331a39 100644 --- a/src/cmp/sysfun.lsp +++ b/src/cmp/sysfun.lsp @@ -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 diff --git a/src/compile.lsp.in b/src/compile.lsp.in index b3c876bd2..d296c3295 100644 --- a/src/compile.lsp.in +++ b/src/compile.lsp.in @@ -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) diff --git a/src/configure b/src/configure index 212d146bd..8492dce24 100755 --- a/src/configure +++ b/src/configure @@ -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" diff --git a/src/configure.in b/src/configure.in index 6e08d238e..93273d87a 100644 --- a/src/configure.in +++ b/src/configure.in @@ -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) diff --git a/src/doc/devel.txi b/src/doc/devel.txi index 636f3e742..0d3eba59b 100644 --- a/src/doc/devel.txi +++ b/src/doc/devel.txi @@ -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 + +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 diff --git a/src/h/config.h.in b/src/h/config.h.in index 409bfde74..026f30bce 100644 --- a/src/h/config.h.in +++ b/src/h/config.h.in @@ -28,6 +28,9 @@ /* Network streams */ #undef TCP +/* Foreign functions interface */ +#undef ECL_FFI + /* * C TYPES AND SYSTEM LIMITS */ diff --git a/src/h/external.h b/src/h/external.h index 4839c2fc4..9b924bed5 100644 --- a/src/h/external.h +++ b/src/h/external.h @@ -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); diff --git a/src/h/object.h b/src/h/object.h index 720e90449..122442771 100644 --- a/src/h/object.h +++ b/src/h/object.h @@ -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 */ diff --git a/src/lsp/autoload.lsp b/src/lsp/autoload.lsp index 8e8459411..310a94075 100644 --- a/src/lsp/autoload.lsp +++ b/src/lsp/autoload.lsp @@ -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) diff --git a/src/lsp/ffi-objects.lsp b/src/lsp/ffi-objects.lsp new file mode 100644 index 000000000..8d97e511a --- /dev/null +++ b/src/lsp/ffi-objects.lsp @@ -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)))) + diff --git a/src/lsp/ffi.lsp b/src/lsp/ffi.lsp index 98439d865..a036412a3 100644 --- a/src/lsp/ffi.lsp +++ b/src/lsp/ffi.lsp @@ -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") diff --git a/src/lsp/load.lsp.in b/src/lsp/load.lsp.in index 11bffa0bf..e2c704863 100644 --- a/src/lsp/load.lsp.in +++ b/src/lsp/load.lsp.in @@ -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 diff --git a/src/lsp/mislib.lsp b/src/lsp/mislib.lsp index 07827f19e..490fd2f55 100644 --- a/src/lsp/mislib.lsp +++ b/src/lsp/mislib.lsp @@ -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))) diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index b2caae387..03c26db5b 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -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 diff --git a/src/lsp/seqlib.lsp b/src/lsp/seqlib.lsp index 888130950..980f098b2 100644 --- a/src/lsp/seqlib.lsp +++ b/src/lsp/seqlib.lsp @@ -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) diff --git a/src/lsp/setf.lsp b/src/lsp/setf.lsp index 68857a7e4..7eeb5aa33 100644 --- a/src/lsp/setf.lsp +++ b/src/lsp/setf.lsp @@ -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}*) diff --git a/src/lsp/top.lsp b/src/lsp/top.lsp index 84703b70d..be6d92f39 100644 --- a/src/lsp/top.lsp +++ b/src/lsp/top.lsp @@ -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)) diff --git a/src/util/emacs.el b/src/util/emacs.el index 483b558c3..15fc9a49c 100644 --- a/src/util/emacs.el +++ b/src/util/emacs.el @@ -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"