Skip to content
Snippets Groups Projects
Commit 42e347c2 authored by gerd's avatar gerd
Browse files

* src/code/fwrappers.lisp (funwrap): Delete all fwrappers

	if neither type nor test is supplied.

	* src/lisp/GNUmakefile: Include internals.inc.

	* src/compiler/generic/new-genesis.lisp (emit-makefile-header): New
	function.
	(genesis): Call it.
parent 0a35e1ab
No related branches found
No related tags found
No related merge requests found
......@@ -27,7 +27,7 @@
;;; USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
;;; DAMAGE.
(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fwrappers.lisp,v 1.3 2003/06/18 09:38:10 gerd Exp $")
(ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/fwrappers.lisp,v 1.4 2003/08/20 16:54:00 gerd Exp $")
(in-package :fwrappers)
......@@ -123,13 +123,15 @@
(defun funwrap (function-name &key (type nil type-p) test)
"Remove fwrappers from the function named FUNCTION-NAME.
If TYPE is supplied, remove fwrappers whose type is equal to TYPE.
If TEST is supplied, remove fwrappers satisfying TEST."
If TEST is supplied, remove fwrappers satisfying TEST.
If both are not specified, remove all fwrappers."
(collect ((new))
(do-fwrappers (f (fdefn-or-lose function-name))
(when (or (not type-p) (not (equal type (fwrapper-type f))))
(when (or (null test) (not (funcall test f)))
(new f))))
(set-fwrappers function-name (new))))
(when (or type-p test)
(do-fwrappers (f (fdefn-or-lose function-name))
(when (or (not type-p) (not (equal type (fwrapper-type f))))
(when (or (null test) (not (funcall test f)))
(new f))))
(set-fwrappers function-name (new)))))
(defun update-fwrapper (f)
"Update the funcallable instance function of fwrapper F from its
......
......@@ -4,7 +4,7 @@
;;; Carnegie Mellon University, and has been placed in the public domain.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.57 2003/05/31 23:58:12 pmai Exp $")
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/new-genesis.lisp,v 1.58 2003/08/20 16:53:59 gerd Exp $")
;;;
;;; **********************************************************************
;;;
......@@ -2357,6 +2357,15 @@
(unix:unix-unlink unix-newname))))
(undefined-value))
(defun emit-makefile-header (name)
(with-open-file (*standard-output* name :direction :output
:if-exists :supersede)
;;
;; Write out features.
(dolist (feature (c:backend-features c:*backend*))
(format t "FEATURE_~a = 1~%"
(substitute #\_ #\- (symbol-name feature))))))
;;;; The actual genesis function.
......@@ -2444,6 +2453,13 @@
(merge-pathnames
header-name
(make-pathname :type "h")))
core-name))
(emit-makefile-header
(merge-pathnames (if (eq header-name t)
"internals.inc"
(merge-pathnames
(make-pathname :type "inc")
header-name))
core-name)))
(write-initial-core-file
core-name version
......
# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/GNUmakefile,v 1.21 2003/05/30 02:46:53 toy Exp $
# $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/lisp/GNUmakefile,v 1.22 2003/08/20 16:53:59 gerd Exp $
all: lisp.nm
......@@ -7,6 +7,7 @@ CC = gcc
DEPEND = $(CC) -MM -E
DEPEND_FLAGS =
-include internals.inc
include Config
ifndef GC_SRC
......@@ -45,7 +46,7 @@ version:
socket.o: socket.c
$(COMPILE.c) -DUNIXCONN $<
internals.h:
internals.h internals.inc:
@echo "You must run genesis to create internals.h!"
@false
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment