common-lisp/roswell.roswell
1
0
Fork 0
mirror of https://github.com/roswell/roswell.git synced 2026-09-10 07:16:17 -04:00
Code Issues Actions 1 Packages Projects Releases Wiki Activity

fix error.

Browse source
This commit is contained in:
SANO Masatoshi 2017-06-12 02:29:32 +09:00
parent bd7bceadae
commit 4a3422a050
2 changed files with 17 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
lisp/dump.ros
View file

@ -104,16 +104,16 @@ exec ros -- $0 "$@"
(defun parse-options (args)
(trivia:match args
((list* (or "--enable-compression" "-c") rest)
(setf *compression* t)
(push `(set *compression* t) *predump*)
(parse-options rest))
((list* "--disable-compression" rest)
(setf *compression* nil)
(push `(set *compression* nil) *predump*)
(parse-options rest))
((list* "--remove-docstrings" rest)
(push (read-from-string "roswell.util.dump:remove-docstrings") *predump*)
(parse-options rest))
((list* "--delete-package" name rest)
(push (lambda () (makunbound-symbols-and-delete-package (string-upcase name))) *predump*)
(push `(makunbound-symbols-and-delete-package ,(string-upcase name)) *predump*)
(parse-options rest))
((list* "--delete-all-packages" rest)
(push 'delete-all-packages *predump*)
@ -159,11 +159,11 @@ exec ros -- $0 "$@"
(remove #\Space (string-downcase (lisp-implementation-type)))))))
(cond
((and module r)
(let* ((func (find mode (funcall module :query *subcmds*)
(let* ((args (parse-options r))
(mode (first args))
(func (find mode (funcall module :query *subcmds*)
:test 'equal
:key 'string-downcase))
(args (parse-options r))
(mode (first args))
(args (rest args)))
(if func
(funcall func module args)

13
lisp/util-dump.lisp
View file

@ -2,7 +2,7 @@
(roswell:include "util" "util-dump")
(defpackage :roswell.util.dump
(:use :cl :roswell.util)
(:export :*compression* :*predump* :*purify* :*impurify* :remove-docstrings
(:export :*compression* :dump-compression :*predump* :*purify* :*impurify* :remove-docstrings
:*package-blacklist* :*additional-blacklist-for-destroy-packages*
:makunbound-symbols-and-delete-package :delete-all-packages
:delete-macro-definitions :delete-compiler-macro-definitions
@ -31,6 +31,9 @@ The default value contains the minimal blacklist.")
These are appended to the blacklist before destroying the package system.
Notably, it must include all nicknames.")
(defun dump-compression (param)
(setf *compression* param))
(defun remove-docstrings ()
"Docstrings are unnecessary when the resulting binary is expected to be a batch program.
With this feature, applications that use docstrings may not work properly."
@ -95,7 +98,13 @@ This is a portable implementation."
(defun preprocess-before-dump ()
(loop for i in (nreverse *predump*)
do (cond ((symbolp i)
do (cond ((and (listp i) (eql (first i) 'set))
(set (second i) (third i)))
((and (listp i)
(eql (first i) 'pushnew)
(not (find (second i) (third i) :test #'equal)))
(set (third i) (cons (second i) (third i))))
((symbolp i)
(funcall i))
((listp i)
(apply (first i) (rest i)))))