[0aaecc]: clocc.lisp  Maximize  Restore  History

Download this file

124 lines (111 with data), 4.6 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
;;; bugfixes
;;;
;;; Copyright (C) 1997-2008, 2010, 2011 by Sam Steingold.
;;; This is open-source software.
;;; GNU Lesser General Public License (LGPL) is applicable:
;;; No warranty; you may copy/modify/redistribute under the same
;;; conditions with the source code.
;;; See <URL:http://www.gnu.org/copyleft/lesser.html>
;;; for details and the precise copyright document.
(in-package :cl-user)
;;;
;;; fix some bugs
;;;
#+allegro
(setq
;; All code here is supposed to be ANSI CL compliant,
;; so there is no use in this annoying warning
comp:*cltl1-compile-file-toplevel-compatibility-p* nil
;; this is necessary for (require "foo") to load "foo.fasl"
;; Kevin Layer (layer@franz.com) [2003-04-16 15:26:42 PST]
;; <http://groups.google.com/groups?hl=en&ie=UTF-8&th=be07905ac53b210d>
sys:*require-search-list*
(append sys:*load-search-list* sys:*require-search-list*)
;; Duane Rettig <duane@franz.com>:
;; TIME reports 32 other bytes too many CL unless tuned with
excl::time-other-base 32)
;; From Erik Naggum <erik@naggum.no> [22 Feb 1999 10:27:45 +0000]
;; fixes the (read-from-string "[#\\x]") problem
#+allegro-off
(loop with readtables = (excl::get-objects 11)
for i from 1 to (aref readtables 0)
for readtable = (aref readtables i) do
(when (excl::readtable-dispatch-tables readtable)
;; reader for character names immune cltl1
(set-dispatch-macro-character
#\# #\\
(excl::named-function
excl::sharp-backslash
(lambda (stream backslash font)
(declare (ignore font))
(unread-char backslash stream)
(let* ((charstring (excl::read-extended-token stream)))
(unless *read-suppress*
(or
;; the original code by Erik
#+(and allegro (not (version>= 6)))
(or (character charstring)
(name-char charstring))
;; From: cox@franz.com (Charles A. Cox)
;; Subject: Re: [spr22970]
;; Date: Thu, 16 Nov 2000 18:43:13 -0800
#+(and allegro (version>= 6))
(if (= 1 (length charstring))
(char charstring 0)
(name-char charstring))
(excl::internal-reader-error
stream "Meaningless character name ~A"
(string-upcase charstring)))))))
readtable)))
#+allegro-v4.3 ; From Erik Naggum <erik@naggum.no>
(unless (member :key (excl:arglist #'reduce) :test #'string=)
(setq excl:*compile-advice* t)
(excl:defadvice reduce (support-key :before)
(let ((key (getf (cddr excl:arglist) :key)))
(when key
(remf (cddr excl:arglist) :key)
(setf (second excl:arglist)
(map 'vector key (second excl:arglist)))))))
#+cmu
(progn
(pushnew 'compile pcl::*defclass-times*)
(pushnew 'compile pcl::*defgeneric-times*)
(pushnew 'compile pcl::*defmethod-times*))
#+cmu (setq ext:*gc-verbose* nil)
(eval-when (:compile-toplevel :execute)
(let (x y)
(handler-case
(progn
(setf (values x y) (values 1 2))
(unless (and (= x 1) (= y 2))
(pushnew :broken-setf-values *features*)))
(error () (pushnew :broken-setf-values *features*)))))
#+broken-setf-values
(define-setf-expander values (&rest places &environment env)
(loop :for pl :in places :with te :and va :and ne :and se :and ge :do
(multiple-value-setq (te va ne se ge) (get-setf-expansion pl env))
:append te :into te1 :append va :into va1 :append ne :into ne1
:collect se :into se1 :collect ge :into ge1
:finally (return (values te1 va1 ne1 (cons 'values se1)
(cons 'values ge1)))))
#+mcl
(import '(ccl:provide) :common-lisp)
;;;
;;; Path
;;;
(defvar *clocc-root*
(namestring (make-pathname :name nil :type nil :defaults *load-truename*))
"*The root CLOCC directory.")
(setf (logical-pathname-translations "clocc")
`(("src;defsystem;*"
,(concatenate 'string *clocc-root* "src/defsystem-3.x/*"))
("src;defsystem;*.*"
,(concatenate 'string *clocc-root* "src/defsystem-3.x/*.*"))
("src;defsystem-3-x;*"
,(concatenate 'string *clocc-root* "src/defsystem-3.x/*"))
("src;defsystem-3-x;*.*"
,(concatenate 'string *clocc-root* "src/defsystem-3.x/*.*"))
("**;*" ,(concatenate 'string *clocc-root* "**/*"))
("**;*.*" ,(concatenate 'string *clocc-root* "**/*.*"))))
(provide :clocc-top)
;;; clocc.lisp ends here

Get latest updates about Open Source Projects, Conferences and News.

Sign up for the SourceForge newsletter:





No, thanks