Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
gendl
gendl
Commits
4ee5d709
Commit
4ee5d709
authored
Mar 09, 2013
by
Dave Cooper
Browse files
removed platform-dependent build directory, cleaned any dependency on asdf from main build.
parent
72df31a2
Changes
19
Hide whitespace changes
Inline
Side-by-side
build/depends-on.isc
deleted
100644 → 0
View file @
72df31a2
(:gdl-geom-base :cl-fad)
build/gdl-build.asd
deleted
100644 → 0
View file @
72df31a2
(
asdf:defsystem
#:gdl-build
:description
"Auto-generated asdf defsys from Genworks GDL cl-lite."
:author
"Genworks and Dave Cooper unless otherwise indicated"
:license
"AGPL unless otherwise indicated"
:serial
t
:version
"2012090900"
:depends-on
(
:gdl-geom-base
:cl-fad
)
:components
((
:lisp
"source/package"
)
(
:lisp
"source/genworks"
)
(
:lisp
"source/app"
)
(
:lisp
"source/distro"
)))
\ No newline at end of file
build/source/app.lisp
deleted
100644 → 0
View file @
72df31a2
;;
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(
in-package
:gdl-build
)
(
define-object
app
()
:computed-slots
((
hey-now
"hey now"
))
:input-slots
((
"String. The name which will be used for your application's executable and dxl file.
Defaults to \"my-gdl-app\""
application-name
"my-gdl-app"
)
(
"Keyword symbol. Should be one of <tt>:runtime</tt>, <tt>:development</tt>,
or <tt>:enterprise</tt>.
Indicates which level of application should be made. Defaults to :development."
application-class
:runtime
)
(
lisp-heap-size
900000000
)
(
implementation-identifier
(
glisp:implementation-identifier
))
(
"Pathname. Indicates the directory to be created or overwritten for producing
the distribution.
Defaults to a directory called <tt>(the application-name)</tt> in the user
temporary directory, returned by <tt>(glisp:temporary-folder)</tt>."
destination-directory
(
make-pathname
:name
nil
:type
nil
:directory
(
append
(
pathname-directory
(
glisp:temporary-folder
))
(
ensure-list
(
the
application-name
)))
:defaults
(
glisp:temporary-folder
)))
(
overwrite?
t
)
(
load-core-gdl-form
`
(
progn
(
load
,
(
merge-pathnames
"../build"
glisp:*genworks-source-home*
))
#+
nil
(
setf
(
symbol-value
(
read-from-string
"asdf:*central-registry*"
))
nil
)))
(
pre-load-form
(
the
load-core-gdl-form
))
(
post-load-form
'
(
progn
(
setf
(
symbol-value
(
read-from-string
"asdf:*central-registry*"
))
nil
)
(
asdf:map-systems
#'
asdf:clear-system
)
(
asdf:clear-output-translations
)
(
asdf:disable-output-translations
)
))
(
init-file-names
nil
)
(
restart-init-function
nil
)
(
modules
nil
)
(
demo-days
30
)
)
:functions
((
make!
()
(
print-variables
(
the
init-file-names
))
(
when
(
and
(
probe-file
(
the
destination-directory
))
(
the
overwrite?
))
(
glisp:delete-directory-and-files
(
the
destination-directory
)))
(
glisp:make-gdl-app
:application-name
(
the
application-name
)
:destination-directory
(
the
destination-directory
)
:modules
(
the
modules
)
:pre-load-form
(
the
pre-load-form
)
:post-load-form
(
the
post-load-form
)
:application-class
(
the
application-class
)
:demo-days
(
the
demo-days
)
:lisp-heap-size
(
the
lisp-heap-size
)
;;
;; FLAG -- leave this to nil for now while we are working
;; on the basic build.
;;
:init-file-names
(
the
init-file-names
)
;;
:restart-init-function
(
the
restart-init-function
)
;;
;;
))))
(
defun
app
(
&rest
args
)
(
let
((
self
(
apply
#'
make-object
'app
args
)))
(
the
make!
)))
;;
;;
;; FLAG -- this is given as an example for how one might create a
;; standalone runtime executable. Note that its restart-init-function
;; modifies the Quicklisp environment, so you would only do this when
;; the user does not already have a known Quicklisp environment.
;;
;;
(
defun
gdl-runtime
()
(
let
((
destination-directory
(
let
((
implementation-identifier
(
glisp:implementation-identifier
))
;;(prefix (merge-pathnames "../../staging/" glisp:*genworks-source-home*))
(
prefix
(
merge-pathnames
#+
mswindows
"e:/staging/"
#-
mswindows
"~/share/staging/"
)))
(
merge-pathnames
(
make-pathname
:directory
(
list
:relative
(
format
nil
"~a-~a"
implementation-identifier
(
glisp:next-datestamp
prefix
implementation-identifier
))))
prefix
))))
(
app
:application-name
"gdl-runtime"
:application-class
:runtime
:destination-directory
destination-directory
:modules
(
list
:agraph
)
:restart-init-function
'
(
lambda
()
(
setq
glisp:*gdl-home*
(
glisp:current-directory
))
(
setq
glisp:*genworks-source-home*
(
merge-pathnames
"src/"
glisp:*gdl-home*
))
(
setf
(
symbol-value
(
read-from-string
"ql:*quicklisp-home*"
))
(
merge-pathnames
"quicklisp/"
glisp:*gdl-home*
))
(
gdl:start-gdl
:edition
:trial
)
(
glisp:set-gs-path
(
merge-pathnames
"gpl/gs/gs8.63/bin/gswin32c.exe"
glisp:*gdl-home*
))))
destination-directory
))
(
defun
gdl
()
(
let
((
destination-directory
(
let
((
implementation-identifier
(
glisp:implementation-identifier
))
;;(prefix (merge-pathnames "../../staging/" glisp:*genworks-source-home*))
(
prefix
(
merge-pathnames
#+
mswindows
(
or
(
probe-file
"e:/staging/"
)
(
probe-file
"z:/staging/"
))
#-
mswindows
"~/share/staging/"
)))
(
merge-pathnames
(
make-pathname
:directory
(
list
:relative
(
format
nil
"~a-~a"
implementation-identifier
(
glisp:next-datestamp
prefix
implementation-identifier
))))
prefix
))))
(
app
:application-name
"gdl"
:application-class
#+
64bit
:runtime
#-
64bit
:development
:destination-directory
destination-directory
:modules
(
list
#-
64bit
:agraph
#-
64bit
:ide
)
:restart-init-function
'
(
lambda
()
(
gdl:start-gdl
:edition
:trial
)))
destination-directory
))
(
defun
site
()
(
app
:post-load-form
'
(
progn
(
require
:smtp
)
(
require
:ftp
)
(
load
(
merge-pathnames
"demos/gdl-demos.asd"
glisp:*genworks-source-home*
))
(
asdf:load-system
:gdl-demos
)
(
load
(
merge-pathnames
"../downloads/gdl-downloads.asd"
glisp:*genworks-source-home*
))
(
asdf:load-system
:gdl-downloads
)
(
load
(
merge-pathnames
"demos/newsite/gdl-newsite.asd"
glisp:*genworks-source-home*
))
(
asdf:load-system
:gdl-newsite
)
(
setf
(
symbol-value
(
read-from-string
"glisp:*genworks-source-home*"
))
nil
))
:destination-directory
(
merge-pathnames
"~/share/staging/site/"
glisp:*genworks-source-home*
)
:overwrite?
t
:application-name
"genworks-site"
:application-class
:development
:demo-days
nil
:restart-init-function
'
(
lambda
()
(
gdl:start-gdl
:edition
:trial
)
(
setf
(
symbol-value
(
read-from-string
"www.genworks.com::*smtp-server*"
))
"localhost"
)
(
glisp:set-gs-path
#+
mswindows
(
merge-pathnames
"gpl/gs/gs8.63/bin/gswin32c.exe"
glisp:*gdl-home*
)))))
build/source/distro.lisp
deleted
100644 → 0
View file @
72df31a2
;;
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(
in-package
:gdl-build
)
(
define-object
distro
()
:input-slots
((
overwrite?
nil
)
(
staging-directory
#+
mswindows
(
or
(
probe-file
"e:/staging/"
)
(
probe-file
"z:/staging/"
))
#-
mswindows
"~/share/staging/"
)
(
release-directory
#+
mswindows
(
or
(
probe-file
"e:/release/"
)
(
probe-file
"z:/release/"
))
#-
mswindows
"~/share/release/"
)
(
release-name-mapping
'
((
"acl-8.2m-linux-x86"
.
"gdl1581-linux"
)
(
"acl-8.2m-win-x86"
.
"gdl1581-windows"
)
(
"acl-9.0m-linux-x86"
.
"gdl1582-linux"
)
(
"acl-9.0m-win-x86"
.
"gdl1582-windows"
)
(
"acl-9.0ms-win-x64"
.
"gdl1582-win64smp"
)
))
(
os-name-mapping
'
((
"win"
.
"windows"
)
(
"linux"
.
"linux"
)
(
"macos"
.
"macos"
)))
(
known-releases
(
mapcar
#'
first
(
the
release-name-mapping
))))
:computed-slots
((
staging-release-pairs
(
let
(
result
)
(
dolist
(
entry
(
glisp:directory-list
(
the
staging-directory
))
(
nreverse
result
))
(
when
(
glisp:file-directory-p
entry
)
(
let*
((
full-name
(
lastcar
(
pathname-directory
entry
)))
(
base
(
when
(
>=
(
length
full-name
)(
length
"-2011010100"
))
(
subseq
full-name
0
(
-
(
length
full-name
)
(
length
"-2011010100"
))))))
(
when
(
member
base
(
the
known-releases
)
:test
#'
string-equal
)
(
push
(
cons
entry
(
merge-pathnames
(
format
nil
"~a/~a~a/program/"
(
the
(
os-name-lookup
base
))
(
rest
(
assoc
base
(
the
release-name-mapping
)
:test
#'
string-equal
))
(
subseq
full-name
(
length
base
)))
(
the
release-directory
)))
result
))))))))
:objects
((
pairs
:type
'staging-release-pair
:sequence
(
:size
(
length
(
the
staging-release-pairs
)))
:pair
(
nth
(
the-child
index
)
(
the
staging-release-pairs
))
:pass-down
(
overwrite?
)))
:functions
((
os-name-lookup
(
base
)
(
dolist
(
mapping
(
the
os-name-mapping
))
(
when
(
search
(
first
mapping
)
base
)
(
return
(
rest
mapping
)))))
(
make!
()
(
dolist
(
pair
(
list-elements
(
the
pairs
)))
(
the-object
pair
make!
)))))
(
define-object
staging-release-pair
()
:input-slots
(
pair
overwrite?
)
:computed-slots
((
source
(
first
(
the
pair
)))
(
target
(
rest
(
the
pair
)))
(
target-parent
(
merge-pathnames
"../"
(
the
target
)))
(
os
(
lastcar
(
butlast
(
pathname-directory
(
the
target-parent
)))))
(
distributed?
(
probe-file
(
merge-pathnames
"distributed.txt"
(
the
source
)))))
:functions
((
make!
()
(
if
(
the
distributed?
)
(
format
t
"~% ~a is Already Distributed (fill in time & date here from contents of distributed.txt)~%~%"
(
the
source
))
(
progn
(
when
(
and
(
probe-file
(
the
target
))
(
the
overwrite?
))
(
glisp:delete-directory-and-files
(
the
target-parent
)
:quiet
t
))
(
unless
(
probe-file
(
the
target-parent
))
(
glisp:copy-directory
(
the
source
)
(
the
target
))
;;
;; Documentation:
;;
(
ensure-directories-exist
(
merge-pathnames
"documentation/"
(
the
target-parent
)))
(
glisp:copy-file
(
merge-pathnames
"documentation/gdl-documentation.pdf"
glisp:*genworks-source-home*
)
(
merge-pathnames
"documentation/gdl-documentation.pdf"
(
the
target-parent
)))
;;
;; GDL source code:
;;
(
glisp:copy-directory
glisp:*genworks-source-home*
(
merge-pathnames
"src/"
(
the
target-parent
)))
(
glisp:delete-directory-and-files
(
merge-pathnames
"src/.git/"
(
the
target-parent
))
:quiet
t
)
(
delete-file
(
merge-pathnames
"src/.gitignore"
(
the
target-parent
)))
;;
;; Quicklisp:
;;
#+
nil
(
glisp:copy-directory
(
merge-pathnames
"../../common/quicklisp/"
glisp:*genworks-source-home*
)
(
merge-pathnames
"quicklisp/"
(
the
target-parent
)))
;;
;; eli:
;;
(
ensure-directories-exist
(
merge-pathnames
"emacs/"
(
the
target-parent
)))
(
glisp:copy-directory
(
translate-logical-pathname
"sys:eli;"
)
(
merge-pathnames
"emacs/eli/"
(
the
target-parent
)))
(
glisp:copy-file
(
merge-pathnames
"dist/emacs/gdl.el"
glisp:*genworks-source-home*
)
(
merge-pathnames
"emacs/gdl.el"
(
the
target-parent
)))
;;
;; Startup batch file or script:
;;
(
if
(
string-equal
(
the
os
)
"windows"
)
(
glisp:copy-file
(
merge-pathnames
"dist/run-gdl.bat"
glisp:*genworks-source-home*
)
(
merge-pathnames
"run-gdl.bat"
(
the
target-parent
)))
(
glisp:copy-file
(
merge-pathnames
"dist/run-gdl"
glisp:*genworks-source-home*
)
(
merge-pathnames
"run-gdl"
(
the
target-parent
))))
;;
;; smlib shared library
;;
(
let
((
smlib-version
"8.51"
))
(
ensure-directories-exist
(
merge-pathnames
(
format
nil
"SMLib~a/"
smlib-version
)
(
the
target-parent
)))
(
let
((
smlib-name
(
if
(
find-package
:smlib
)
(
funcall
(
read-from-string
"glisp:smlib-name"
))
(
error
"smlib-name not known (smlib module probably not loaded)."
))))
(
glisp:copy-file
(
merge-pathnames
(
format
nil
"../../common/SMLib~a/~a"
smlib-version
smlib-name
)
glisp:*genworks-source-home*
)
(
merge-pathnames
(
format
nil
"SMLib~a/~a"
smlib-version
smlib-name
)
(
the
target-parent
)))))
;;
;; gpl on windows
;;
#+
nil
(
when
(
string-equal
(
the
os
)
"windows"
)
(
glisp:copy-directory
(
merge-pathnames
"../../common/gpl/"
glisp:*genworks-source-home*
)
(
merge-pathnames
"gpl/"
(
the
target-parent
))))))))))
(
defun
distro
(
&rest
args
)
(
let
((
self
(
apply
#'
make-object
'distro
args
)))
(
the
make!
)))
\ No newline at end of file
build/source/file-ordering.isc
deleted
100644 → 0
View file @
72df31a2
("package" "genworks")
build/source/genworks.lisp
deleted
100644 → 0
View file @
72df31a2
;;
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(
in-package
:com.genworks.lisp
)
(
defun
copy-file
(
from
to
&key
overwrite?
)
(
fad:copy-file
from
to
:overwrite
overwrite?
))
;;
;; FLAG -- replace with cl-fad version.
;;
(
defun
copy-directory
(
from-dir
to-dir
&rest
args
)
(
declare
(
ignore
args
))
#+
allegro
(
excl:copy-directory
from-dir
to-dir
)
#+
lispworks
(
cl-copy-directory
to-dir
from-dir
)
#+
clozure
(
ccl::recursive-copy-directory
from-dir
to-dir
))
(
defun
delete-directory-and-files
(
target
&key
force
quiet
(
if-does-not-exist
:error
))
#-
allegro
(
declare
(
ignore
force
quiet
))
(
cond
((
probe-file
target
)
#+
lispworks
(
system:run-shell-command
(
format
nil
"rm -rf ~a"
target
))
#+
allegro
(
excl.osi:delete-directory-and-files
target
:force
force
:quiet
quiet
)
#-
(
or
allegro
(
and
unix
lispworks
))
(
cl-fad:delete-directory-and-files
target
:if-does-not-exist
if-does-not-exist
))
((
null
if-does-not-exist
)
nil
)
(
t
(
ecase
if-does-not-exist
(
:ignore
nil
)
(
:warn
(
warn
"Target ~s does not exist.~%"
target
))
(
:error
(
error
"Target ~s does not exist.~%"
target
))))))
#+
allegro
(
ff:
def-foreign-call
(
memory-status-dump
"memory_status_dump"
)
())
(
defun
dump-memory
(
&key
(
output-name
"mem"
)
(
output-type
"txt"
)
(
output-path
(
merge-pathnames
(
make-pathname
:name
output-name
:type
output-type
)
(
glisp:temporary-folder
))))
#+
allegro
(
let
((
status
(
memory-status-dump
(
namestring
(
translate-logical-pathname
output-path
)))))
(
unless
(
zerop
status
)
(
error
"~&memory-status-dump failed with non-zero return code: ~a~%~%"
status
))
output-path
)
#-
allegro
(
declare
(
ignore
output-path
))
#-
allegro
(
error
"Need implementation of dump-memory for currently running lisp."
))
(
defun
implementation-identifier
()
(
asdf::implementation-identifier
))
#-
allegro
(
warn
"~&Please implement generate-application for the currently running lisp.~%"
)
(
defun
make-gdl-app
(
&rest
args
)
#+
allegro
(
let
((
app-name
(
getf
args
:application-name
))
(
target
(
getf
args
:destination-directory
))
(
modules
(
append
(
list
:asdf
:compftype
:aserve
:phtml
#+
mswindows
:winapi
)
(
getf
args
:modules
)))
(
args
(
normalize-generate-application-args
args
)))
(
apply
#'
excl:generate-application
app-name
target
modules
args
))
#-
allegro
(
declare
(
ignore
args
))
#-
allegro
(
error
"~&generate-application is not implemented for the currently running lisp.~%"
))
#+
allegro
(
defun
normalize-generate-application-args
(
args
)
(
let
((
class
(
getf
args
:application-class
)))
(
list
:runtime
(
case
class
(
:development
:partners
)
(
otherwise
:standard
))
:include-compiler
(
case
class
(
:development
t
)
(
otherwise
nil
))
:include-devel-env
(
case
class
(
:development
t
)
(
otherwise
nil
))
:icon-file
(
merge-pathnames
"gdl/gwl/static/gwl/images/favicon.ico"
glisp:*genworks-source-home*
)
:demo
(
getf
args
:demo-days
)
:lisp-heap-size
(
getf
args
:lisp-heap-size
)
:close-oldspace
t
:init-file-names
(
getf
args
:init-file-names
)
:pre-load-form
(
getf
args
:pre-load-form
)
:post-load-form
(
getf
args
:post-load-form
)
:restart-init-function
(
getf
args
:restart-init-function
)
:purify
t
:autoload-warning
nil
:runtime-bundle
t
:suppress-allegro-cl-banner
t
)))
(
defun
next-datestamp
(
prefix
base
)
(
let*
((
base-length
(
length
base
))
(
directory
(
directory
prefix
))
(
files
(
mapcar
#'
(
lambda
(
item
)
(
let
((
name
(
pathname-name
item
))
(
type
(
pathname-type
item
)))
(
format
nil
"~a~a~a"
name
(
if
type
"."
""
)
(
or
type
""
))))
directory
))
(
matches
(
sort
(
remove-if-not
#'
(
lambda
(
file
)
(
and
(
>
(
length
file
)
base-length
)
(
string-equal
(
subseq
file
0
base-length
)
base
)))
files
)
#'
string-greaterp
))
(
datestamps
(
remove
nil
(
mapcar
#'
(
lambda
(
match
)
(
let
((
datestamp
(
subseq
match
(
1+
base-length
))))
(
if
(
not
(
get-decoded-datestamp
datestamp
))
(
warn
"Invalid datestamp ~a on file ~a in directory ~a.~%"
datestamp
match
prefix
)
datestamp
)))
matches
)))
(
latest
(
first
datestamps
)))
(
multiple-value-bind
(
latest-serial-number
latest-date
latest-month
latest-year
)
(
when
latest
(
get-decoded-datestamp
latest
))
(
multiple-value-bind
(
seconds
minutes
hours
date
month
year
)
(
get-decoded-time
)
(
declare
(
ignore
seconds
minutes
hours
))
(
let
((
new-serial-number
(
if
(
and
latest
(
=
latest-date
date
)
(
=
latest-month
month
)
(
=
latest-year
year
))
(
1+
latest-serial-number
)
0
)))
(
format
nil
"~a~2,'0d~2,'0d~2,'0d"
year
month
date
new-serial-number
))))))
(
defun
get-decoded-datestamp
(
datestamp
)
(
let
(
*read-eval*
)
(
when
(
and
(
=
(
length
datestamp
)
10
)
(
integerp
(
read-from-string
datestamp
)))
(
let
((
year
(
read-from-string
(
subseq
datestamp
0
4
)))
(
month
(
read-from-string
(
subseq
datestamp
4
6
)))
(
date
(
read-from-string
(
subseq
datestamp
6
8
)))
(
serial-number
(
read-from-string
(
subseq
datestamp
8
10
))))
(
when
(
ignore-errors
(
encode-universal-time
0
0
0
date
month
year
))
(
values
serial-number
date
month
year
))))))
build/source/package.lisp
deleted
100644 → 0
View file @
72df31a2
;;
;; Copyright 2002-2011 Genworks International
;;
;; This source file is part of the General-purpose Declarative
;; Language project (GDL).
;;
;; and/or modify it under the terms of the GNU Affero General Public
;; License as published by the Free Software Foundation, either
;; version 3 of the License, or (at your option) any later version.
;;
;; This source file is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; Affero General Public License for more details.
;;
;; You should have received a copy of the GNU Affero General Public
;; License along with this source file. If not, see
;; <http://www.gnu.org/licenses/>.
;;
(
in-package
:gdl-user
)
(
gdl:define-package
:gdl-build
(
:export
#:app
#:gdl
#:distro
#:site
))
gdl/apps/yadd/source/define-object-documentation.lisp
View file @
4ee5d709
...
...
@@ -455,7 +455,7 @@ If you specify :part-symbol-supplied, do not specify :instance-supplied."))
pdf-file
)))
(
let
((
return-value
(
glisp:run-
shell-command
command
:show-window?
nil
)))
(
glisp:run-
program
command
:show-window?
nil
)))
(
with-http-response
(
req
ent
)
(
setf
(
reply-header-slot-value
req
:cache-control
)
"no-cache"
)
(
setf
(
reply-header-slot-value
req
:pragma
)
"no-cache"
)
...
...
gdl/base/common/genworks.lisp
View file @
4ee5d709
...
...
@@ -26,15 +26,27 @@
#-
(
and
mswindows
allegro
)
:default
)
(
defun
system-home
(
system-designator
)
(
asdf:system-source-directory
system-designator
))
(
defparameter
*genworks-source-home*
(
let
((
gdl-base-home
(
system-home
"gdl-base"
)))
(
make-pathname
:name
nil
:type
nil
:directory
(
butlast
(
butlast
(
pathname-directory
gdl-base-home
)))
:defaults
gdl-base-home
)))
(
if
(
find-package
:asdf
)
(
funcall
(
read-from-string
"asdf:system-source-directory"
)
system-designator
)
(
error
"~&glisp:system-home was called, but cannot function because asdf is not loaded.~%"
)))
(
defparameter
*genworks-source-home*
nil
)
(
eval-when
(
:compile-toplevel
:load-toplevel
:execute
)
(
defun
set-genworks-source-home-if-known
()
(
when
(
find-package
:asdf
)
(
multiple-value-bind
(
gdl-base-home
error
)
(
ignore-errors
(
funcall
(
read-from-string
"asdf:system-source-directory"
)
"gdl-base"
))
(
if
(
typep
error
'error
)
(
warn
"~&ASDF is loaded, but :gdl-base is not registered. glisp:*genworks-source-home* remains unknown and set to nil.~%"
)
(
setq
*genworks-source-home*
(
make-pathname
:name
nil
:type
nil
:directory
(
butlast
(
butlast
(
pathname-directory
gdl-base-home
)))
:defaults
gdl-base-home
)))))))
(
set-genworks-source-home-if-known
)