Commit 81f65db4 authored by Raymond Toy's avatar Raymond Toy
Browse files

Merge branch 'master' into file-attribute

parents 7ed74511 8a9d1d8d
......@@ -4944,7 +4944,7 @@ The result is a symbol or nil if the routine cannot be found."
(error (intl:gettext "Cannot set breakpoints for editor when ~
there is no start positions map.")))
(with-open-file (f name)
(with-open-file (f name :external-format (c::debug-source-info d-source))
((= (debug-source-created d-source) (file-write-date name))
(file-position f char-offset))
......@@ -1486,7 +1486,7 @@ See the CMU Common Lisp User's Manual for more information.
(when *cached-source-stream* (close *cached-source-stream*))
(setq *cached-source-stream*
(open name :if-does-not-exist nil
:external-format (or (c::debug-source-info d-source) :default)))
:external-format (c::debug-source-info d-source)))
(unless *cached-source-stream*
(error (intl:gettext "Source file no longer exists:~% ~A.") (namestring name)))
(format t (intl:gettext "~%; File: ~A~%") (namestring name)))
......@@ -1985,6 +1985,12 @@
;;;; Creation routines (MAKE-FD-STREAM and OPEN)
;; The unicode version of this is in fd-stream-extfmt.lisp
#-(and unicode (not unicode-boootstrap))
(defun %set-fd-stream-external-format (stream extfmt &optional (updatep t))
(declare (ignore stream extfmt updatep))
;;; MAKE-FD-STREAM -- Public.
;;; Returns a FD-STREAM on the given file.
......@@ -1153,7 +1153,7 @@
(:block-compile (member t nil :specified))
(:entry-points list)
(:byte-compile (member t nil :maybe))
(:external-format symbol)
(:external-format (or symbol list))
(:decoding-error (or null symbol function))
(:xref t))
(values (or pathname null) boolean boolean))
......@@ -2570,7 +2570,7 @@
(when (vm:primitive-object-header obj)
(format t " lispobj header;~%"))
(dolist (slot (vm:primitive-object-slots obj))
(format t " ~A ~A~@[[1]~];~%"
(format t " ~A ~A~@[[]~];~%"
(getf (vm:slot-options slot) :c-type "lispobj")
(nsubstitute #\_ #\-
(string-downcase (string (vm:slot-name slot))))
......@@ -1210,11 +1210,10 @@
(if (atom form)
(convert-and-maybe-compile form path)
(case (car form)
((make-package shadow shadowing-import export
unexport use-package unuse-package import
old-in-package %in-package %defpackage)
((%in-package %defpackage)
(process-cold-load-form form path t))
((error cerror break signal)
((error cerror break signal make-package use-package unuse-package shadow
shadowing-import export unexport import)
(process-cold-load-form form path nil))
(convert-and-maybe-compile form path)
;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.21: Another System Definition Facility.
;;; This is ASDF 2.22: Another System Definition Facility.
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <>.
......@@ -116,7 +116,7 @@
;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(asdf-version "2.21")
(asdf-version "2.22")
(existing-asdf (find-class 'component nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
......@@ -1343,7 +1343,7 @@ processed in order by OPERATE."))
:initarg :if-component-dep-fails
:accessor module-if-component-dep-fails)
:initform *default-component-class*
:initform nil
:initarg :default-component-class
:accessor module-default-component-class)))
......@@ -2788,6 +2788,11 @@ details."
(defun* find-class* (x &optional (errorp t) environment)
(etypecase x
((or standard-class built-in-class) x)
(symbol (find-class x errorp environment))))
(defun* class-for-type (parent type)
(or (loop :for symbol :in (list
......@@ -2799,8 +2804,10 @@ details."
class (find-class 'component)))
:return class)
(and (eq type :file)
(or (and parent (module-default-component-class parent))
(find-class *default-component-class*)))
(or (loop :for module = parent :then (component-parent module) :while module
:thereis (module-default-component-class module))
*default-component-class*) nil))
(sysdef-error "don't recognize component type ~A" type)))
(defun* maybe-add-tree (tree op1 op2 c)
......@@ -2886,7 +2893,7 @@ Returns the new tree (which probably shares structure with the old one)"
(type name &rest rest &key
;; the following list of keywords is reproduced below in the
;; remove-keys form. important to keep them in sync
components pathname default-component-class
components pathname
perform explain output-files operation-done-p
weakly-depends-on depends-on serial in-order-to
......@@ -2913,7 +2920,7 @@ Returns the new tree (which probably shares structure with the old one)"
:pathname pathname
:parent parent
'(components pathname default-component-class
'(components pathname
perform explain output-files operation-done-p
weakly-depends-on depends-on serial in-order-to)
......@@ -2927,10 +2934,6 @@ Returns the new tree (which probably shares structure with the old one)"
(setf ret (apply 'make-instance (class-for-type parent type) args)))
(component-pathname ret) ; eagerly compute the absolute pathname
(when (typep ret 'module)
(setf (module-default-component-class ret)
(or default-component-class
(and (typep parent 'module)
(module-default-component-class parent))))
(let ((*serial-depends-on* nil))
(setf (module-components ret)
......@@ -3687,7 +3690,7 @@ Please remove it from your ASDF configuration"))
#+sbcl ,(let ((h (getenv "SBCL_HOME")))
(when (plusp (length h)) `((,(truenamize h) ,*wild-inferiors*) ())))
;; The below two are not needed: no precompiled ASDF system there
;; #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
#+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
;; All-import, here is where we want user stuff to be:
......@@ -4011,21 +4014,24 @@ with a different configuration, so the configuration would be re-read then."
(defun* directory-files (directory &optional (pattern *wild-file*))
(setf directory (pathname directory))
(when (wild-pathname-p directory)
(error "Invalid wild in ~S" directory))
(unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
(error "Invalid file pattern ~S" pattern))
(when (typep directory 'logical-pathname)
(setf pattern (make-pathname-logical pattern (pathname-host directory))))
(let ((entries (ignore-errors (directory* (merge-pathnames* pattern directory)))))
directory entries
#'(lambda (f)
(make-pathname :defaults directory
:name (pathname-name f)
:type (make-pathname-component-logical (pathname-type f))
:version (make-pathname-component-logical (pathname-version f)))))))
(let ((dir (pathname directory)))
(when (typep dir 'logical-pathname)
;; Because of the filtering we do below,
;; logical pathnames have restrictions on wild patterns.
;; Not that the results are very portable when you use these patterns on physical pathnames.
(when (wild-pathname-p dir)
(error "Invalid wild pattern in logical directory ~S" directory))
(unless (member (pathname-directory pattern) '(() (:relative)) :test 'equal)
(error "Invalid file pattern ~S for logical directory ~S" pattern directory))
(setf pattern (make-pathname-logical pattern (pathname-host dir))))
(let ((entries (ignore-errors (directory* (merge-pathnames* pattern dir)))))
directory entries
#'(lambda (f)
(make-pathname :defaults dir
:name (make-pathname-component-logical (pathname-name f))
:type (make-pathname-component-logical (pathname-type f))
:version (make-pathname-component-logical (pathname-version f))))))))
(defun* directory-asd-files (directory)
(directory-files directory *wild-asd*))
......@@ -4399,7 +4405,7 @@ with a different configuration, so the configuration would be re-read then."
(let ((*verbose-out* (make-broadcast-stream))
(system (find-system (string-downcase name) nil)))
(when system
(operate *require-asdf-operator* system :verbose nil)
(operate *require-asdf-operator* system :verbose nil :force-not (loaded-systems))
#+(or abcl clisp clozure cmu ecl sbcl)
......@@ -1035,7 +1035,10 @@
;;; Here I add the proper defpackage for CMU
(defpackage "MAKE" (:use "COMMON-LISP" "CONDITIONS")
(:nicknames "MK"))
(:nicknames "MK")
(defpackage "MAKE" (:use "COMMON-LISP")
......@@ -30,7 +30,7 @@ New in this release:
* Added external format for EUC-KR.
* Changes
* ASDF2 updated to version 2.21.
* ASDF2 updated to version 2.22.
* Behavior of STRING-TO-OCTETS has changed. This is an
incompatible change from the previous version but should be more
useful when a buffer is given which is not large enough to hold
......@@ -76,6 +76,16 @@ New in this release:
* Fix typo in ISO8859-2 external format that caused it not to work
correctly. This type potentially also caused failures for all other
external formats that were based on ISO8859-2.
* COMPILE-FILE should not signal an error when given a list for
:EXTERNAL-FORMAT. Lists are needed to specify a composing
external format like :DOS or :MAC.
* EXPORT and friends should not EVAL the form when compiling.
This was probably a leftover from the time when CMUCL did not
have DEFPACKAGE. (See ticket:60.)
* The debugger was not always opening the file in the correct
external format. It defaulted to using
*DEFAULT-EXTERNAL-FORMAT* instead of the format used when
compiling the file.
* Trac Tickets:
* #50: Print/read error with make-pathname.
......@@ -83,6 +93,7 @@ New in this release:
* #52: UNICODE-COMPLETE-NAME misses a completion.
* #55: blocked signals.
* #58: UTF-16 buffering problem.
* #60: compile-file and export problem
* Other changes:
* The layout of the cmucl directories has been changed.
......@@ -45,7 +45,24 @@ ifdef FEATURE_UNICODE
# Default to using gcc
CC = gcc
# But we can use clang.
# However, clang seems to want to use SSE instructions in various
# places, but we DON'T want that because we need a lisp that will run
# on chips without sse.
# But on Mac, every machine has SSE2 so we can use SSE2. However,
# there's some code path through GC or allocation where we aren't
# saving the FPU state so after GC or allocation, some XMM FP
# registers are corrupted.
# Got that?
#CC = clang -mno-sse
LD = ld
ifeq ($(filter 2% 3%, $(shell $(CC) -dumpversion)),)
......@@ -70,3 +87,4 @@ DEPEND_FLAGS =
# -ffloat-store and -fno-strict-aliasing anymore.
e_rem_pio2.o : e_rem_pio2.c
$(CC) -c $(CFLAGS) $(CPPFLAGS) $<
......@@ -451,6 +451,9 @@ gc_write_barrier(void *addr)
* A structure to hold the state of a generation.
#define MEM_AGE_SHIFT 16
struct generation {
/* The first page that gc_alloc checks on its next call. */
......@@ -502,8 +505,11 @@ struct generation {
* A minimum average memory age before a GC will occur helps prevent
* a GC when a large number of new live objects have been added, in
* which case a GC could be a waste of time.
* The age is represented as an integer between 0 and 32767
* corresponding to an age of 0 to (just less than) 1.
double min_av_mem_age;
int min_av_mem_age;
......@@ -524,7 +530,7 @@ struct generation_stats {
int num_gc;
int trigger_age;
int cum_sum_bytes_allocated;
double min_av_mem_age;
int min_av_mem_age;
......@@ -647,14 +653,14 @@ generation_bytes_allocated(int generation)
* Return the average age of the memory in a generation.
static double
static int
gen_av_mem_age(int gen)
if (generations[gen].bytes_allocated == 0)
return 0.0;
return 0;
return (double) generations[gen].cum_sum_bytes_allocated /
(double) generations[gen].bytes_allocated;
return (((long) generations[gen].cum_sum_bytes_allocated) << MEM_AGE_SHIFT) /
......@@ -753,7 +759,7 @@ print_generation_stats(int verbose)
GC_PAGE_SIZE * count_generation_pages(i) -
generations[i].bytes_allocated, generations[i].gc_trigger,
count_write_protect_generation_pages(i), generations[i].num_gc,
(double)gen_av_mem_age(i) / MEM_AGE_SCALE);
fprintf(stderr, " Total bytes alloc=%ld\n", bytes_allocated);
......@@ -804,7 +810,7 @@ void
set_min_mem_age(int gen, double min_mem_age)
if (gen <= NUM_GENERATIONS) {
generations[gen].min_av_mem_age = min_mem_age;
generations[gen].min_av_mem_age = min_mem_age * MEM_AGE_SCALE;
......@@ -4532,7 +4538,20 @@ scav_hash_vector(lispobj * where, lispobj object)
fprintf(stderr, "scav_hash_vector: scavenge table %p\n", hash_table);
* Check to see that hash-table-rehash-threshold is a single
* float in the range (0, 1]
lispobj threshold_obj = (lispobj) hash_table->rehash_threshold;
float* raw_slots = PTR(threshold_obj);
float threshold = raw_slots[2];
gc_assert(threshold > 0 && threshold <= 1);
scavenge((lispobj *) hash_table, HASH_TABLE_SIZE);
if (hash_table->weak_p == NIL) {
......@@ -7325,7 +7344,7 @@ garbage_collect_generation(int generation, int raise)
#if defined(i386) || defined(__x86_64)
invalid_stack_start = (void *) control_stack_start;
invalid_stack_start = (void *) CONTROL_STACK_START;
invalid_stack_end = (void *) &raise;
#else /* not i386 */
invalid_stack_start = (void *) &raise;
......@@ -7897,7 +7916,7 @@ gc_init(void)
/* The tune-able parameters */
generations[i].bytes_consed_between_gc = 2000000;
generations[i].trigger_age = 1;
generations[i].min_av_mem_age = 0.75;
generations[i].min_av_mem_age = 24508; /* 0.75 * MEM_AGE_SCALE */
/* Initialise gc_alloc */
......@@ -32,6 +32,94 @@
:nicknames '("HI")
(:nicknames "HI")
(unless (find-package "HEMLOCK")
(make-package "HEMLOCK"
:nicknames '("ED")
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment