Initial CL parser/generator implementation
This commit is contained in:
6
.gitmodules
vendored
Normal file
6
.gitmodules
vendored
Normal file
@ -0,0 +1,6 @@
|
||||
[submodule "tools/cl-ppcre"]
|
||||
path = tools/cl-ppcre
|
||||
url = https://apps.pmsf.net/stash/scm/oscl/cl-ppcre.git
|
||||
[submodule "tools/cl-yacc"]
|
||||
path = tools/cl-yacc
|
||||
url = https://github.com/jech/cl-yacc.git
|
||||
39
OSN.asd
Normal file
39
OSN.asd
Normal file
@ -0,0 +1,39 @@
|
||||
;;;; OpenScenarioNext --- OpenScenario Language Design
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; OSN.asd --- Central System Definition for ASDF
|
||||
|
||||
(cl:in-package #:cl-user)
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; This file contains the system definition form for the OSN
|
||||
;;;; Workbench. System definitions use the ASDF system definition
|
||||
;;;; facility.
|
||||
;;;;
|
||||
|
||||
;;;
|
||||
;;; OSN itself
|
||||
;;;
|
||||
|
||||
(asdf:defsystem "OSN"
|
||||
:description "Workbench for OpenScenarioNext"
|
||||
:author "Pierre R. Mai <pmai@pmsf.de>"
|
||||
:components ((:module "lib"
|
||||
:components
|
||||
((:file "pkgdef")
|
||||
(:file "macro-utilities"
|
||||
:depends-on ("pkgdef"))
|
||||
(:file "common-utilities"
|
||||
:depends-on ("pkgdef"))
|
||||
(:file "parsing-utilities"
|
||||
:depends-on ("pkgdef"))))
|
||||
(:module "src"
|
||||
:components
|
||||
((:file "pkgdef")
|
||||
(:file "conditions" :depends-on ("pkgdef"))
|
||||
(:file "osn" :depends-on ("pkgdef"))
|
||||
(:file "osn-parser" :depends-on ("pkgdef" "conditions" "osn"))
|
||||
(:file "osn-writer" :depends-on ("pkgdef" "conditions" "osn")))
|
||||
:depends-on ("lib")))
|
||||
:depends-on ("cl-ppcre" "yacc"))
|
||||
25
lib/COPYING
Normal file
25
lib/COPYING
Normal file
@ -0,0 +1,25 @@
|
||||
Copyright (C) 1995-2017 Pierre R. Mai
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining
|
||||
a copy of this software and associated documentation files (the
|
||||
"Software"), to deal in the Software without restriction, including
|
||||
without limitation the rights to use, copy, modify, merge, publish,
|
||||
distribute, sublicense, and/or sell copies of the Software, and to
|
||||
permit persons to whom the Software is furnished to do so, subject to
|
||||
the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be
|
||||
included in all copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
||||
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
|
||||
IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY CLAIM, DAMAGES OR
|
||||
OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE,
|
||||
ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
|
||||
OTHER DEALINGS IN THE SOFTWARE.
|
||||
|
||||
Except as contained in this notice, the name of the author shall
|
||||
not be used in advertising or otherwise to promote the sale, use or
|
||||
other dealings in this Software without prior written authorization
|
||||
from the author.
|
||||
3
lib/README
Normal file
3
lib/README
Normal file
@ -0,0 +1,3 @@
|
||||
This directory contains excerpts of the PMSF Common Lisp Library (PMSF-Lib)
|
||||
necessary for FMIBench. See COPYING for the licence governing the files
|
||||
contained in this directory.
|
||||
244
lib/aes-utilities.lisp
Normal file
244
lib/aes-utilities.lisp
Normal file
@ -0,0 +1,244 @@
|
||||
;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; aes-utilities.lisp --- Utilities concerned with AES
|
||||
;;;;
|
||||
;;;; $Id$
|
||||
|
||||
(cl:in-package #:pmsf-lib)
|
||||
|
||||
(pmsf-lib:file-version :pmsf-lib "$Id$")
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; This file contains utilities for AES encryption
|
||||
;;;;
|
||||
|
||||
(defvar *aes-processing-pathname* nil)
|
||||
|
||||
(define-condition aes-processing-error (simple-error)
|
||||
((pathname :initarg :pathname :initform *aes-processing-pathname*
|
||||
:reader aes-processing-error-pathname))
|
||||
(:report
|
||||
(lambda (c s)
|
||||
(with-standard-io-syntax
|
||||
(let ((*print-readably* nil))
|
||||
(format s
|
||||
"Error processing AES encryption~@[ for ~A~]: ~?"
|
||||
(aes-processing-error-pathname c)
|
||||
(simple-condition-format-control c)
|
||||
(simple-condition-format-arguments c)))))))
|
||||
|
||||
(defun aes-processing-error (datum &rest arguments)
|
||||
(error 'aes-processing-error :format-control datum :format-arguments arguments))
|
||||
|
||||
(defparameter *crypt-aes-provider*
|
||||
"Microsoft Enhanced RSA and AES Cryptographic Provider")
|
||||
(defconstant +prov-rsa-aes+ 24)
|
||||
(defconstant +crypt-verify-context+ #xF0000000)
|
||||
(defconstant +crypt-silent+ #x00000040)
|
||||
|
||||
(fli:define-foreign-function (crypt-acquire-context "CryptAcquireContext" :dbcs)
|
||||
((:ignore (:reference-return win32:handle))
|
||||
(container (:reference-pass (:ef-wc-string :external-format :unicode :null-terminated-p t) :allow-null t))
|
||||
(provider (:reference-pass (:ef-wc-string :external-format :unicode :null-terminated-p t)))
|
||||
(prov-type win32:dword)
|
||||
(flags win32:dword))
|
||||
:result-type win32:bool
|
||||
:calling-convention :stdcall)
|
||||
|
||||
(fli:define-foreign-function (crypt-release-context "CryptReleaseContext")
|
||||
((hprov win32:handle)
|
||||
(flags win32:dword))
|
||||
:result-type win32:bool
|
||||
:calling-convention :stdcall)
|
||||
|
||||
(fli:define-c-typedef crypt-aes-256-key-data
|
||||
(:c-array (:unsigned :byte) 32))
|
||||
|
||||
(fli:define-c-typedef crypt-aes-256-iv-data
|
||||
(:c-array (:unsigned :byte) 16))
|
||||
|
||||
(fli:define-c-struct crypt-aes-256-key
|
||||
(type (:unsigned :byte))
|
||||
(version (:unsigned :byte))
|
||||
(reserved win32:word)
|
||||
(alg-id (:unsigned :int))
|
||||
(key-size win32:dword)
|
||||
(key-data crypt-aes-256-key-data))
|
||||
|
||||
(fli:define-foreign-function (crypt-gen-random "CryptGenRandom")
|
||||
((hprov win32:handle)
|
||||
(data-len win32:dword)
|
||||
(data (:pointer (:unsigned :byte))))
|
||||
:result-type win32:bool
|
||||
:calling-convention :stdcall)
|
||||
|
||||
(fli:define-foreign-function (crypt-import-key "CryptImportKey")
|
||||
((hprov win32:handle)
|
||||
(data (:pointer crypt-aes-256-key))
|
||||
(data-len win32:dword)
|
||||
(pub-key win32:handle)
|
||||
(flags win32:dword)
|
||||
(:ignore (:reference-return win32:handle)))
|
||||
:result-type win32:bool
|
||||
:calling-convention :stdcall)
|
||||
|
||||
(fli:define-foreign-function (crypt-set-key-param "CryptSetKeyParam")
|
||||
((hkey win32:handle)
|
||||
(param win32:dword)
|
||||
(data (:pointer (:unsigned :byte)))
|
||||
(flags win32:dword))
|
||||
:result-type win32:bool
|
||||
:calling-convention :stdcall)
|
||||
|
||||
(fli:define-foreign-function (crypt-encrypt "CryptEncrypt")
|
||||
((hkey win32:handle)
|
||||
(hhash win32:handle)
|
||||
(finalp win32:bool)
|
||||
(flags win32:dword)
|
||||
(data (:pointer (:unsigned :byte)))
|
||||
(data-len (:reference win32:dword))
|
||||
(buf-len win32:dword))
|
||||
:result-type win32:bool
|
||||
:calling-convention :stdcall)
|
||||
|
||||
(fli:define-foreign-function (crypt-decrypt "CryptDecrypt")
|
||||
((hkey win32:handle)
|
||||
(hhash win32:handle)
|
||||
(finalp win32:bool)
|
||||
(flags win32:dword)
|
||||
(data (:pointer (:unsigned :byte)))
|
||||
(data-len (:reference win32:dword)))
|
||||
:result-type win32:bool
|
||||
:calling-convention :stdcall)
|
||||
|
||||
(fli:define-foreign-function (crypt-destroy-key "CryptDestroyKey")
|
||||
((hkey win32:handle))
|
||||
:result-type win32:bool
|
||||
:calling-convention :stdcall)
|
||||
|
||||
(defmacro with-aes-winapi-call (vars form cleanup &body body)
|
||||
(with-unique-names (ok-p)
|
||||
`(multiple-value-bind (,ok-p ,@vars) ,form
|
||||
(unless ,ok-p
|
||||
(aes-processing-error
|
||||
"Failed CryptAPI call (~A), Error: ~A" ',(car form)
|
||||
(win32:get-last-error-string)))
|
||||
(unwind-protect (progn ,@body)
|
||||
,cleanup))))
|
||||
|
||||
(defun aes-encode-buffer (buffer size &key key-in iv-in)
|
||||
(with-aes-winapi-call (hprov)
|
||||
(crypt-acquire-context nil *crypt-aes-provider*
|
||||
+prov-rsa-aes+
|
||||
(logior +crypt-verify-context+
|
||||
+crypt-silent+))
|
||||
(crypt-release-context hprov 0)
|
||||
(fli:with-dynamic-foreign-objects ((key crypt-aes-256-key)
|
||||
(iv crypt-aes-256-iv-data))
|
||||
(setf (fli:foreign-slot-value key 'type) #x8
|
||||
(fli:foreign-slot-value key 'version) 2
|
||||
(fli:foreign-slot-value key 'reserved) 0
|
||||
(fli:foreign-slot-value key 'alg-id) #x00006610
|
||||
(fli:foreign-slot-value key 'key-size) 32)
|
||||
(let ((key-data (fli:foreign-slot-pointer key 'key-data)))
|
||||
(if key-in
|
||||
(loop for i upfrom 0 for val across key-in
|
||||
do (setf (fli:foreign-aref key-data i) val))
|
||||
(with-aes-winapi-call ()
|
||||
(crypt-gen-random hprov 32 (fli:foreign-array-pointer key-data 0))
|
||||
t)))
|
||||
(if iv-in
|
||||
(loop for i upfrom 0 for val across iv-in
|
||||
do (setf (fli:foreign-aref iv i) val))
|
||||
(with-aes-winapi-call ()
|
||||
(crypt-gen-random hprov 16 (fli:foreign-array-pointer iv 0))
|
||||
t))
|
||||
(with-aes-winapi-call (hkey)
|
||||
(crypt-import-key hprov key (+ 32 4 4 4) 0 0)
|
||||
(crypt-destroy-key hkey)
|
||||
(with-aes-winapi-call ()
|
||||
(crypt-set-key-param hkey 1 (fli:foreign-array-pointer iv 0) 0)
|
||||
t
|
||||
(fli:with-dynamic-lisp-array-pointer (buffer-ptr buffer :type '(:unsigned :byte))
|
||||
(with-aes-winapi-call (enc-len)
|
||||
(crypt-encrypt hkey 0 t 0 buffer-ptr size (length buffer))
|
||||
t
|
||||
(values
|
||||
buffer
|
||||
enc-len
|
||||
(let ((key-out (make-array 32 :element-type '(unsigned-byte 8))))
|
||||
(fli:replace-foreign-array key-out (fli:foreign-slot-pointer key 'key-data))
|
||||
key-out)
|
||||
(let ((iv-out (make-array 16 :element-type '(unsigned-byte 8))))
|
||||
(fli:replace-foreign-array iv-out iv)
|
||||
iv-out)))))))))
|
||||
|
||||
(defun aes-decode-buffer (buffer size key-in iv-in)
|
||||
(with-aes-winapi-call (hprov)
|
||||
(crypt-acquire-context nil *crypt-aes-provider*
|
||||
+prov-rsa-aes+
|
||||
(logior +crypt-verify-context+
|
||||
+crypt-silent+))
|
||||
(crypt-release-context hprov 0)
|
||||
(fli:with-dynamic-foreign-objects ((key crypt-aes-256-key)
|
||||
(iv crypt-aes-256-iv-data))
|
||||
(setf (fli:foreign-slot-value key 'type) #x8
|
||||
(fli:foreign-slot-value key 'version) 2
|
||||
(fli:foreign-slot-value key 'reserved) 0
|
||||
(fli:foreign-slot-value key 'alg-id) #x00006610
|
||||
(fli:foreign-slot-value key 'key-size) 32)
|
||||
(let ((key-data (fli:foreign-slot-pointer key 'key-data)))
|
||||
(loop for i upfrom 0 for val across key-in
|
||||
do (setf (fli:foreign-aref key-data i) val)))
|
||||
(loop for i upfrom 0 for val across iv-in
|
||||
do (setf (fli:foreign-aref iv i) val))
|
||||
(with-aes-winapi-call (hkey)
|
||||
(crypt-import-key hprov key (+ 32 4 4 4) 0 0)
|
||||
(crypt-destroy-key hkey)
|
||||
(with-aes-winapi-call ()
|
||||
(crypt-set-key-param hkey 1 (fli:foreign-array-pointer iv 0) 0)
|
||||
t
|
||||
(fli:with-dynamic-lisp-array-pointer (buffer-ptr buffer :type '(:unsigned :byte))
|
||||
(with-aes-winapi-call (dec-len)
|
||||
(crypt-decrypt hkey 0 t 0 buffer-ptr size)
|
||||
t
|
||||
(values
|
||||
buffer
|
||||
dec-len))))))))
|
||||
|
||||
(defun aes-encode-file (from to &key key-in iv-in)
|
||||
(let ((*aes-processing-pathname* from))
|
||||
(with-open-file (in from :element-type '(unsigned-byte 8))
|
||||
(with-open-file (out to :element-type '(unsigned-byte 8)
|
||||
:direction :output)
|
||||
(let* ((length (file-length in))
|
||||
(buffer (make-array (* (ceiling (1+ length) 16) 16)
|
||||
:element-type '(unsigned-byte 8)
|
||||
:allocation :static)))
|
||||
(unless (= length (read-sequence buffer in :end length))
|
||||
(aes-processing-error
|
||||
"Failed to read ~D bytes from ~A!" length from))
|
||||
(multiple-value-bind (out-buffer out-length key iv)
|
||||
(aes-encode-buffer buffer length
|
||||
:key-in key-in :iv-in iv-in)
|
||||
(write-sequence out-buffer out :end out-length)
|
||||
(values length key iv)))))))
|
||||
|
||||
(defun aes-decode-file (from to key-in iv-in)
|
||||
(let ((*aes-processing-pathname* from))
|
||||
(with-open-file (in from :element-type '(unsigned-byte 8))
|
||||
(with-open-file (out to :element-type '(unsigned-byte 8)
|
||||
:direction :output)
|
||||
(let* ((length (file-length in))
|
||||
(buffer (make-array length
|
||||
:element-type '(unsigned-byte 8)
|
||||
:allocation :static)))
|
||||
(unless (= length (read-sequence buffer in :end length))
|
||||
(aes-processing-error
|
||||
"Failed to read ~D bytes from ~A!" length from))
|
||||
(multiple-value-bind (out-buffer out-length)
|
||||
(aes-decode-buffer buffer length key-in iv-in)
|
||||
(write-sequence out-buffer out :end out-length)
|
||||
out-length))))))
|
||||
269
lib/cmdline-utilities.lisp
Normal file
269
lib/cmdline-utilities.lisp
Normal file
@ -0,0 +1,269 @@
|
||||
;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; cmdline-utilities.lisp --- Command Line Parsing and Access
|
||||
;;;;
|
||||
;;;; $Id$
|
||||
|
||||
(cl:in-package #:pmsf-lib)
|
||||
|
||||
(pmsf-lib:file-version :pmsf-lib "$Id$")
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; This file contains utilities to access the command line and to
|
||||
;;;; parse command line arguments for options and proper arguments.
|
||||
;;;;
|
||||
|
||||
(defun get-command-line-arguments ()
|
||||
"Return the list of command line arguments passed to this process, including
|
||||
the program name as its first argument."
|
||||
#+sbcl
|
||||
(copy-list sb-ext:*posix-argv*)
|
||||
#+lispworks
|
||||
(copy-list system:*line-arguments-list*))
|
||||
|
||||
;;;
|
||||
;;; Parsing
|
||||
;;;
|
||||
|
||||
(define-condition command-line-argument-error (simple-error)
|
||||
((command-line :initarg :command-line
|
||||
:reader command-line-argument-error-command-line)
|
||||
(remaining-arguments :initarg :remaining-arguments
|
||||
:reader
|
||||
command-line-argument-error-remaining-arguments))
|
||||
(:report
|
||||
(lambda (c s)
|
||||
(with-standard-io-syntax
|
||||
(let ((*print-readably* nil))
|
||||
(format s
|
||||
"Error parsing command-line: ~?~%~
|
||||
For command-line ~{~S~^ ~}, remaining arguments: ~{~S~^ ~}"
|
||||
(simple-condition-format-control c)
|
||||
(simple-condition-format-arguments c)
|
||||
(command-line-argument-error-command-line c)
|
||||
(command-line-argument-error-remaining-arguments c)))))))
|
||||
|
||||
;;;
|
||||
;;; Main Entry Point
|
||||
;;;
|
||||
|
||||
(defun parse-command-line-arguments (command-line
|
||||
&key (required-arguments 0) allowed-arguments
|
||||
option-specs)
|
||||
"Parse the command-line given in COMMAND-LINE for the program-name, the
|
||||
normal arguments and any options, based on the specifications given through
|
||||
REQUIRED-ARGUMENTS, ALLOWED-ARGUMENTS and OPTION-SPECS. This function will
|
||||
signal a COMMAND-LINE-ARGUMENT-ERROR if any of those specifications can't be
|
||||
matched. Returns three values, the name of the program as a string, the list
|
||||
of normal arguments after option processing finished, and an alist of options
|
||||
and their arguments, as specified by option-spec."
|
||||
(let ((program-name (first command-line))
|
||||
(arguments (rest command-line)))
|
||||
(flet ((is-long-option-p (arg)
|
||||
(when (and (>= (length arg) 2) (string= arg "--" :end1 2))
|
||||
(subseq arg 2)))
|
||||
(find-option-by-name (name)
|
||||
(find name option-specs :key #'first :test #'string=))
|
||||
(is-option-terminator-p (name)
|
||||
(string= name ""))
|
||||
(command-line-argument-error (rest control &rest args)
|
||||
(error 'command-line-argument-error
|
||||
:command-line command-line
|
||||
:remaining-arguments rest
|
||||
:format-control control
|
||||
:format-arguments args)))
|
||||
;; Process and collect options
|
||||
(loop with options = nil
|
||||
with rest-arguments = arguments
|
||||
for arg = (pop rest-arguments)
|
||||
for option-name = (and arg (is-long-option-p arg))
|
||||
for option = (and option-name (find-option-by-name option-name))
|
||||
while (and option-name (not (is-option-terminator-p option-name)))
|
||||
do
|
||||
(unless option
|
||||
(command-line-argument-error
|
||||
rest-arguments
|
||||
"Unknown option ~A, known options: ~{~A~^, ~}"
|
||||
option-name (mapcar #'first option-specs)))
|
||||
(destructuring-bind (option-matcher option-key option-arguments)
|
||||
option
|
||||
(unless (>= (length rest-arguments) option-arguments)
|
||||
(command-line-argument-error
|
||||
rest-arguments
|
||||
"Option ~A needs ~D arguments but has only ~D."
|
||||
option-matcher option-arguments (length rest-arguments)))
|
||||
(push (list* option-key
|
||||
(subseq rest-arguments 0 option-arguments))
|
||||
options)
|
||||
(setq rest-arguments (nthcdr option-arguments rest-arguments)))
|
||||
finally
|
||||
(when arg
|
||||
(unless (and option-name (is-option-terminator-p option-name))
|
||||
(push arg rest-arguments)))
|
||||
(unless (>= (length rest-arguments) required-arguments)
|
||||
(command-line-argument-error
|
||||
rest-arguments
|
||||
"~A needs ~D arguments but has only ~D."
|
||||
program-name required-arguments (length rest-arguments)))
|
||||
(unless (or (null allowed-arguments)
|
||||
(<= (length rest-arguments) allowed-arguments))
|
||||
(command-line-argument-error
|
||||
rest-arguments
|
||||
"~A needs at most ~D arguments but has ~D."
|
||||
program-name allowed-arguments (length rest-arguments)))
|
||||
(return (values program-name rest-arguments (nreverse options)))))))
|
||||
|
||||
;;;
|
||||
;;; Parsing for lambda lists
|
||||
;;;
|
||||
|
||||
(defun make-options-argument-list (options)
|
||||
(loop with result = nil
|
||||
for (option . args) in options
|
||||
do
|
||||
(cond
|
||||
((null args)
|
||||
(setf (getf result option) t))
|
||||
(t
|
||||
(push args (getf result option nil))))
|
||||
finally
|
||||
(return
|
||||
(loop for (key values) on result by #'cddr
|
||||
collect key
|
||||
collect
|
||||
(cond
|
||||
((eq values t)
|
||||
values)
|
||||
((and (null (cdr values)) (null (cdar values)))
|
||||
(caar values))
|
||||
((null (cdr values))
|
||||
(car values))
|
||||
(t
|
||||
(mapcar #'(lambda (x) (if (null (cdr x)) (car x) x))
|
||||
values)))))))
|
||||
|
||||
(defun parse-command-line-for-argument-list (command-line &rest args)
|
||||
"Parse the command-line given in COMMAND-LINE in order to construct an
|
||||
argument list for invoking another function, based on the specifications
|
||||
given through the remaining arguments, which will be passed to the function
|
||||
PARSE-COMMAND-LINE-ARGUMENTS for the parsing itself. This function returns
|
||||
an argument list, which will contain a position argument for each normal
|
||||
argument to the function, followed by keyword arguments for each option
|
||||
present in the command-line. Duplicate options are merged, options with
|
||||
no argument are turned into boolean T keyword arguments, and options with
|
||||
only single arguments are unwrapped into single keyword arguments."
|
||||
(multiple-value-bind (prog-name arguments options)
|
||||
(apply #'parse-command-line-arguments command-line args)
|
||||
(declare (ignore prog-name))
|
||||
(append arguments (make-options-argument-list options))))
|
||||
|
||||
;;;
|
||||
;;; Main Entry Point
|
||||
;;;
|
||||
|
||||
(defun call-with-parsed-arguments (function command-line &rest args)
|
||||
"Invoke the given function with the arguments and options parsed out of the
|
||||
command-line as given by COMMAND-LINE."
|
||||
(apply function
|
||||
(apply #'parse-command-line-for-argument-list command-line args)))
|
||||
|
||||
(defun call-with-parsed-command-line (function &rest args)
|
||||
"Invoke the given function with the arguments and options parsed out of the
|
||||
command-line as returned by GET-COMMAND-LINE-ARGUMENTS."
|
||||
(apply function
|
||||
(apply #'parse-command-line-for-argument-list
|
||||
(get-command-line-arguments) args)))
|
||||
|
||||
(defun parse-argument-lambda-list (lambda-list)
|
||||
(loop with state = :required
|
||||
with program-arg = nil
|
||||
with required-args = nil
|
||||
with optional-args = nil
|
||||
with rest-arg = nil
|
||||
with keyword-args = nil
|
||||
for arg in lambda-list
|
||||
do
|
||||
(if (member arg '(&optional &rest &program &key))
|
||||
(case arg
|
||||
(&optional
|
||||
(unless (eq state :required)
|
||||
(error "Misplaced &OPTIONAL in command-line lambda list: ~S"
|
||||
lambda-list))
|
||||
(setq state :optional))
|
||||
(&rest
|
||||
(unless (member state '(:required :optional))
|
||||
(error "Misplaced &REST in command-line lambda list: ~S"
|
||||
lambda-list))
|
||||
(setq state :rest))
|
||||
(&program
|
||||
(unless (member state '(:required :optional :post-rest))
|
||||
(error "Misplaced &PROGRAM in command-line lambda list: ~S"
|
||||
lambda-list))
|
||||
(setq state :program))
|
||||
(&key
|
||||
(unless (member state
|
||||
'(:required :optional :post-rest :post-program))
|
||||
(error "Misplaced &KEY in command-line lambda list: ~S"
|
||||
lambda-list))
|
||||
(setq state :key)))
|
||||
(ecase state
|
||||
(:required (push arg required-args))
|
||||
(:optional (push arg optional-args))
|
||||
(:rest (setq rest-arg arg
|
||||
state :post-rest))
|
||||
(:program (setq program-arg arg
|
||||
state :post-program))
|
||||
(:key (push arg keyword-args))))
|
||||
finally
|
||||
(when (eq state :rest)
|
||||
(error "Missing &REST argument in command-line lambda list: ~S"
|
||||
lambda-list))
|
||||
(when (eq state :program)
|
||||
(error "Missing &PROGRAM argument in command-line lambda list: ~S"
|
||||
lambda-list))
|
||||
(return
|
||||
(values
|
||||
program-arg
|
||||
(nreverse required-args)
|
||||
(nreverse optional-args)
|
||||
rest-arg
|
||||
(nreverse keyword-args)))))
|
||||
|
||||
(defmacro with-parsed-arguments ((&rest lambda-list) command-line &body body)
|
||||
(multiple-value-bind (program-arg required-args optional-args
|
||||
rest-arg keyword-args)
|
||||
(parse-argument-lambda-list lambda-list)
|
||||
(let ((required-argcount (length required-args))
|
||||
(allowed-argcount (unless rest-arg
|
||||
(+ (length required-args)
|
||||
(length optional-args))))
|
||||
(real-program-arg (or program-arg (gensym)))
|
||||
(argument-ll (append required-args
|
||||
(when optional-args
|
||||
(cons '&optional optional-args))
|
||||
(when rest-arg
|
||||
(list '&rest rest-arg)))))
|
||||
(multiple-value-bind (option-specs option-ll)
|
||||
(loop for (var name args . default) in keyword-args
|
||||
collect (list name var args) into option-specs
|
||||
collect `((,var ,var) ,(car default)) into option-ll
|
||||
finally
|
||||
(return (values option-specs (list* '&key option-ll))))
|
||||
(pmsf-lib:with-unique-names (arguments options)
|
||||
`(multiple-value-bind (,real-program-arg ,arguments ,options)
|
||||
(parse-command-line-arguments ,command-line
|
||||
:option-specs ',option-specs
|
||||
:required-arguments
|
||||
,required-argcount
|
||||
:allowed-arguments
|
||||
,allowed-argcount)
|
||||
(declare (ignorable ,real-program-arg))
|
||||
(destructuring-bind ((,@argument-ll) (,@option-ll))
|
||||
(list ,arguments (make-options-argument-list ,options))
|
||||
,@body)))))))
|
||||
|
||||
(defmacro with-parsed-command-line ((&rest lambda-list) &body body)
|
||||
`(with-parsed-arguments (,@lambda-list) (get-command-line-arguments)
|
||||
,@body))
|
||||
34
lib/common-utilities.lisp
Normal file
34
lib/common-utilities.lisp
Normal file
@ -0,0 +1,34 @@
|
||||
;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; common-utilities.lisp --- Common utilities
|
||||
;;;;
|
||||
;;;; $Id$
|
||||
|
||||
(cl:in-package #:pmsf-lib)
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; This file contains common utilities for all kinds of processing
|
||||
;;;; and formatting.
|
||||
;;;;
|
||||
|
||||
(defun generate-printed-guid (&optional registry-format-p)
|
||||
"Generate a version 4 (PRNG) UUID and return its printed representation."
|
||||
(let ((state (make-random-state t)))
|
||||
(with-output-to-string (stream)
|
||||
(loop with chars = "0123456789abcdef"
|
||||
for index upfrom 0 below 32
|
||||
for value = (random 16 state)
|
||||
for offset = (cond
|
||||
((= index 12) 4)
|
||||
((= index 16) (+ 8 (ldb (byte 2 0) value)))
|
||||
(t value))
|
||||
do
|
||||
(write-char (char chars offset) stream)
|
||||
(when (member index '(7 11 15 20))
|
||||
(write-char #\- stream))
|
||||
initially
|
||||
(when registry-format-p (write-char #\{ stream))
|
||||
finally
|
||||
(when registry-format-p (write-char #\} stream))))))
|
||||
87
lib/doc.lisp
Normal file
87
lib/doc.lisp
Normal file
@ -0,0 +1,87 @@
|
||||
;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; doc.lisp --- Documentation of file origins and versions
|
||||
;;;;
|
||||
;;;; $Id$
|
||||
|
||||
(cl:in-package #:pmsf-lib)
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; This file provides mechanisms to record the id of files compiled
|
||||
;;;; and loaded to create a runtime image.
|
||||
;;;;
|
||||
|
||||
(defvar *file-versions* nil
|
||||
"Associaton list of loaded file-ids.")
|
||||
|
||||
(defmacro file-version (system id-string)
|
||||
"Register the File-Id `id-string' in the system `system'."
|
||||
;; On CMUCL we use `ext:file-comment' in addition to our own
|
||||
;; tracking, so that the File-Id gets embedded in the fasl, and can
|
||||
;; be seen in descriptions of functions, etc. See the documentation
|
||||
;; of `ext:file-comment' for more details.
|
||||
`(progn
|
||||
#+cmucl
|
||||
(ext:file-comment ,id-string)
|
||||
;; Do compile-time processing by MD5 checksumming the file itself.
|
||||
(process-file-version ',system *load-truename* ',id-string
|
||||
',*compile-file-truename*
|
||||
',(md5:md5sum-file *compile-file-truename*))))
|
||||
|
||||
(defun process-file-version (system file-name id-string
|
||||
source-file-name source-md5)
|
||||
"Load-time part of `file-version'."
|
||||
(let* ((system-list (or (assoc system *file-versions*)
|
||||
(let ((sys (cons system nil)))
|
||||
(push sys *file-versions*)
|
||||
sys)))
|
||||
(file-entry (or (assoc file-name (cdr system-list) :test #'equal)
|
||||
(let ((entry (cons file-name nil)))
|
||||
(push entry (cdr system-list))
|
||||
entry))))
|
||||
(setf (cdr file-entry)
|
||||
(list id-string (md5:md5sum-file file-name)
|
||||
source-file-name source-md5))
|
||||
nil))
|
||||
|
||||
(defun get-file-versions (system)
|
||||
(let ((system-list (assoc system *file-versions*)))
|
||||
(if system-list
|
||||
(cdr system-list)
|
||||
(error "System ~S not found!" system))))
|
||||
|
||||
(defun list-file-versions (system)
|
||||
(loop for (path id) in (get-file-versions system)
|
||||
do
|
||||
(format t "~20A ~A~%" path id)
|
||||
initially
|
||||
(format t "~&~20A ~A~2%" "Path" "Version-Id")))
|
||||
|
||||
(defun list-file-checksums (system)
|
||||
(loop for (path nil md5) in (get-file-versions system)
|
||||
do
|
||||
(format t "~40A ~{~2,'0X~}~%" path (coerce md5 'list))
|
||||
initially
|
||||
(format t "~&~40A ~32A~2%" "Path" "MD5")))
|
||||
|
||||
(defun list-source-checksums (system)
|
||||
(loop for (nil nil nil source-path source-md5) in (get-file-versions system)
|
||||
do
|
||||
(format t "~40A ~{~2,'0X~}~%" source-path (coerce source-md5 'list))
|
||||
initially
|
||||
(format t "~&~40A ~32A~2%" "Source-Path" "MD5")))
|
||||
|
||||
(defun md5-file-versions (system)
|
||||
(md5:md5sum-string
|
||||
(with-output-to-string (stream)
|
||||
(loop for (path id md5) in (sort (copy-list (get-file-versions system))
|
||||
#'string< :key
|
||||
(lambda (x)
|
||||
(if (pathnamep (car x))
|
||||
(namestring (car x))
|
||||
(car x))))
|
||||
do
|
||||
(format stream "~A!~A!~{~2,'0X~}~%" path id (coerce md5 'list))))
|
||||
:external-format :utf-8))
|
||||
318
lib/float-utilities.lisp
Normal file
318
lib/float-utilities.lisp
Normal file
@ -0,0 +1,318 @@
|
||||
;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; float-utilities.lisp --- Floating Point Utilities
|
||||
;;;;
|
||||
;;;; $Id$
|
||||
|
||||
(cl:in-package #:pmsf-lib)
|
||||
|
||||
(pmsf-lib:file-version :pmsf-lib "$Id$")
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; This file contains utilities for handling floating point
|
||||
;;;; numbers and their processing.
|
||||
;;;;
|
||||
|
||||
;;;
|
||||
;;; Prevent compilation errors in this file due to FPU issues
|
||||
;;;
|
||||
|
||||
#+SBCL
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(sb-int:set-floating-point-modes :traps nil :rounding-mode :nearest
|
||||
:fast-mode nil
|
||||
#+X86 :precision #+X86 :53-bit))
|
||||
|
||||
(defconstant single-float-positive-infinity
|
||||
#+sbcl
|
||||
sb-ext:single-float-positive-infinity
|
||||
#-sbcl
|
||||
(+ most-positive-single-float most-positive-single-float)
|
||||
"Single Float Positivie Infinity")
|
||||
|
||||
(defconstant single-float-negative-infinity
|
||||
#+sbcl
|
||||
sb-ext:single-float-negative-infinity
|
||||
#-sbcl
|
||||
(- (+ most-positive-single-float most-positive-single-float))
|
||||
"Single Float Negative Infinity")
|
||||
|
||||
(defconstant single-float-nan
|
||||
;; Ensure positive NaN
|
||||
(float-sign 1.0f0
|
||||
(/ single-float-negative-infinity single-float-negative-infinity))
|
||||
"Single Float NaN")
|
||||
|
||||
(defconstant double-float-positive-infinity
|
||||
#+sbcl
|
||||
sb-ext:double-float-positive-infinity
|
||||
#-sbcl
|
||||
(+ most-positive-double-float most-positive-double-float)
|
||||
"Double Float Positive Infinity")
|
||||
|
||||
(defconstant double-float-negative-infinity
|
||||
#+sbcl
|
||||
sb-ext:double-float-negative-infinity
|
||||
#-sbcl
|
||||
(- (+ most-positive-double-float most-positive-double-float))
|
||||
"Double Float Negative Infinity")
|
||||
|
||||
(defconstant double-float-nan
|
||||
;; Ensure positive NaN
|
||||
(float-sign 1.0d0
|
||||
(/ double-float-negative-infinity double-float-negative-infinity))
|
||||
"Double Float NaN")
|
||||
|
||||
(defun float-infinity-p (float)
|
||||
(and
|
||||
(floatp float)
|
||||
#+sbcl
|
||||
(sb-ext:float-infinity-p float)
|
||||
#-sbcl
|
||||
(etypecase float
|
||||
(double-float (or (= float double-float-positive-infinity)
|
||||
(= float double-float-negative-infinity)))
|
||||
(single-float (or (= float single-float-positive-infinity)
|
||||
(= float single-float-negative-infinity))))))
|
||||
|
||||
(defun float-nan-p (float)
|
||||
(and
|
||||
(floatp float)
|
||||
#+sbcl
|
||||
(sb-ext:float-nan-p float)
|
||||
#+lispworks
|
||||
(system::nan-p float)
|
||||
#-(or sbcl lispworks)
|
||||
(not (= float float))))
|
||||
|
||||
(defun float-denormalized-p (float)
|
||||
(and
|
||||
(floatp float)
|
||||
#+sbcl
|
||||
(sb-ext:float-denormalized-p float)
|
||||
#-sbcl
|
||||
(and (not (float-nan-p float))
|
||||
(not (float-infinity-p float))
|
||||
(not (zerop float))
|
||||
(< (float-precision float) (float-digits float)))))
|
||||
|
||||
;;;
|
||||
;;; Floating-Point Compare
|
||||
;;;
|
||||
|
||||
(defun bit-decode-float (a)
|
||||
"Decode the floating point number A into three numbers MANTISSA, EXPONENT
|
||||
and SIGN, so that A = SIGN * MANTISSA * 2^EXPONENT, and the returned MANTISSA
|
||||
is an integer that is bit-identical to the mantissa field of the floating
|
||||
point number in IEEE 754 with the hidden MSB included."
|
||||
(multiple-value-bind (mantissa exp sign) (decode-float a)
|
||||
(values (truncate (* mantissa (expt 2 (float-digits a))))
|
||||
(- exp (float-digits a))
|
||||
sign)))
|
||||
|
||||
(defun ieee-decode-float (a)
|
||||
"Decode the floating point number A into three numbers MANTISSA, EXPONENT
|
||||
and SIGN, so that A = SIGN * MANTISSA * 2^EXPONENT, and the returned MANTISSA
|
||||
is a floating point number with 1 <= MANTISSA < 2, thus matching the IEEE 754
|
||||
definition of the mantissa."
|
||||
(multiple-value-bind (mantissa exp sign) (decode-float a)
|
||||
(values (* mantissa 2)
|
||||
(1- exp)
|
||||
sign)))
|
||||
|
||||
(defun float-equal (a b &key epsilon-bits)
|
||||
"Compare to floating point numbers A and B on equality, treating two NaNs
|
||||
as equal as well. If EPSILON-BITS is supplied it is the number of least
|
||||
significant bits that the two mantissas are allowed to differ to still be
|
||||
treated as equal for the purposes of the comparison."
|
||||
(unless (or (null epsilon-bits)
|
||||
(<= 0 epsilon-bits (float-digits a)))
|
||||
(error "Illegal value ~S for epsilon-bits in call to float-equal."
|
||||
epsilon-bits))
|
||||
(or
|
||||
;; NaNs
|
||||
(and (float-nan-p a) (float-nan-p b))
|
||||
;; Identical
|
||||
(eql a b)
|
||||
;; Identical modulo epsilon bits differences
|
||||
(when epsilon-bits
|
||||
(unless (or (float-infinity-p a) (float-infinity-p b))
|
||||
(multiple-value-bind (mant-a exp-a sign-a) (bit-decode-float a)
|
||||
(multiple-value-bind (mant-b exp-b sign-b) (bit-decode-float b)
|
||||
(and (= exp-a exp-b)
|
||||
(= sign-a sign-b)
|
||||
(< (abs (- mant-a mant-b)) (expt 2 epsilon-bits)))))))))
|
||||
|
||||
;;;
|
||||
;;; Floating-Point I/O
|
||||
;;;
|
||||
|
||||
(defun read-double-float-from-string (string)
|
||||
(cond
|
||||
((string-equal string "NaN")
|
||||
double-float-nan)
|
||||
((or (string-equal string "+Inf")
|
||||
(string-equal string "Inf"))
|
||||
double-float-positive-infinity)
|
||||
((string-equal string "-Inf")
|
||||
double-float-negative-infinity)
|
||||
((cl-ppcre:scan "^[-+]?([0-9]+)?[.]?(?(1)[0-9]*|[0-9]+)([eE][-+]?[0-9]+)?$"
|
||||
string)
|
||||
(let ((*read-default-float-format* 'double-float)
|
||||
(*read-eval* nil))
|
||||
#+lispworks
|
||||
(hcl:parse-float string)
|
||||
#-lispworks
|
||||
(coerce
|
||||
(read-from-string string)
|
||||
'double-float)))
|
||||
(t
|
||||
(error "Value ~S is not a valid floating point number." string))))
|
||||
|
||||
(defun read-single-float-from-string (string)
|
||||
(cond
|
||||
((string-equal string "NaN")
|
||||
single-float-nan)
|
||||
((or (string-equal string "+Inf")
|
||||
(string-equal string "Inf"))
|
||||
single-float-positive-infinity)
|
||||
((string-equal string "-Inf")
|
||||
single-float-negative-infinity)
|
||||
((cl-ppcre:scan "^[-+]?([0-9]+)?[.]?(?(1)[0-9]*|[0-9]+)([eE][-+]?[0-9]+)?$"
|
||||
string)
|
||||
(let ((*read-default-float-format* 'single-float)
|
||||
(*read-eval* nil))
|
||||
#+lispworks
|
||||
(hcl:parse-float string)
|
||||
#-lispworks
|
||||
(coerce
|
||||
(read-from-string string)
|
||||
'single-float)))
|
||||
(t
|
||||
(error "Value ~S is not a valid floating point number." string))))
|
||||
|
||||
(defun write-float (x stream)
|
||||
(cond
|
||||
((float-infinity-p x)
|
||||
(if (< x (float 0 x))
|
||||
(write-string "-INF" stream)
|
||||
(write-string "INF" stream)))
|
||||
((float-nan-p x)
|
||||
(write-string "NaN" stream))
|
||||
(t
|
||||
(with-standard-io-syntax
|
||||
(let ((*read-default-float-format* (if (typep x 'double-float)
|
||||
'double-float
|
||||
'single-float)))
|
||||
(write x :stream stream))))))
|
||||
|
||||
(defun float-integer-value (a)
|
||||
"Decode the floating point number A so as to produce the corresponding IEEE-754
|
||||
bit pattern as an integer value."
|
||||
(let ((mantissa-bits (1- (float-digits a)))
|
||||
(exponent-bits (etypecase a (double-float 11) (single-float 8))))
|
||||
(multiple-value-bind (mantissa exponent sign)
|
||||
(cond
|
||||
;; NaNs
|
||||
((float-nan-p a)
|
||||
(values (1- (expt 2 mantissa-bits))
|
||||
(1- (expt 2 exponent-bits))
|
||||
0))
|
||||
;; Infinities
|
||||
((float-infinity-p a)
|
||||
(values 0
|
||||
(1- (expt 2 exponent-bits))
|
||||
(if (minusp (float-sign a)) 1 0)))
|
||||
;; Zero is special as well
|
||||
((zerop a)
|
||||
(values 0
|
||||
0
|
||||
(if (minusp (float-sign a)) 1 0)))
|
||||
;; Normals and Denormals
|
||||
(t
|
||||
(multiple-value-bind (mantissa exp sign) (ieee-decode-float a)
|
||||
(if (not (plusp (+ exp (1- (expt 2 (1- exponent-bits))))))
|
||||
;; Denormals
|
||||
(values (ldb (byte mantissa-bits 0)
|
||||
(truncate
|
||||
(* mantissa
|
||||
(expt 2
|
||||
(+ mantissa-bits (1- exp)
|
||||
(1- (expt 2 (1- exponent-bits))))))))
|
||||
0
|
||||
(if (minusp sign) 1 0))
|
||||
;; Normals
|
||||
(values (ldb (byte mantissa-bits 0)
|
||||
(truncate (* mantissa (expt 2 mantissa-bits))))
|
||||
(+ exp (1- (expt 2 (1- exponent-bits))))
|
||||
(if (minusp sign) 1 0))))))
|
||||
;; Construct result
|
||||
(dpb sign (byte 1 (+ mantissa-bits exponent-bits))
|
||||
(dpb exponent (byte exponent-bits mantissa-bits)
|
||||
mantissa)))))
|
||||
|
||||
(defun write-hex (x width stream &optional hide-prefix)
|
||||
(format stream "~:[0x~;~]~v,'0X"
|
||||
hide-prefix
|
||||
(ceiling width 4)
|
||||
(if (floatp x)
|
||||
(float-integer-value x)
|
||||
(ldb (byte width 0) x))))
|
||||
|
||||
(defun pprint-float (stream object &optional colon-p at-sign-p width)
|
||||
(if (and at-sign-p width)
|
||||
(write-hex object width stream colon-p)
|
||||
(write-float object stream)))
|
||||
|
||||
(defun integer-float-value (a type)
|
||||
"Encode an integer A that is constructed according to the IEEE-754 format
|
||||
description into a floating point number of the given common lisp type."
|
||||
(let ((mantissa-bits (ecase type (double-float 52) (single-float 23)))
|
||||
(exponent-bits (ecase type (double-float 11) (single-float 8))))
|
||||
(multiple-value-bind (mantissa exponent sign)
|
||||
(values (ldb (byte mantissa-bits 0) a)
|
||||
(ldb (byte exponent-bits mantissa-bits) a)
|
||||
(ldb (byte 1 (+ exponent-bits mantissa-bits)) a))
|
||||
(cond
|
||||
;; NaNs
|
||||
((and (= exponent (1- (expt 2 exponent-bits))) (/= mantissa 0))
|
||||
(ecase type
|
||||
(double-float double-float-nan)
|
||||
(single-float single-float-nan)))
|
||||
;; Infinities
|
||||
((= exponent (1- (expt 2 exponent-bits)))
|
||||
(if (= sign 1)
|
||||
(ecase type
|
||||
(double-float double-float-negative-infinity)
|
||||
(single-float single-float-negative-infinity))
|
||||
(ecase type
|
||||
(double-float double-float-positive-infinity)
|
||||
(single-float single-float-positive-infinity))))
|
||||
;; Zero is special as well
|
||||
((and (zerop exponent) (zerop mantissa))
|
||||
(if (= sign 1)
|
||||
(ecase type
|
||||
(double-float -0.0d0)
|
||||
(single-float -0.0f0))
|
||||
(ecase type
|
||||
(double-float 0.0d0)
|
||||
(single-float 0.0f0))))
|
||||
;; Denormals
|
||||
((zerop exponent)
|
||||
(float-sign
|
||||
(coerce (if (= sign 1) -1 1) type)
|
||||
(scale-float (coerce mantissa type)
|
||||
(- (+ (1- (expt 2 (1- exponent-bits))) (1- mantissa-bits))))))
|
||||
;; Normals
|
||||
(t
|
||||
(float-sign
|
||||
(coerce (if (= sign 1) -1 1) type)
|
||||
(scale-float (coerce (dpb 1 (byte 1 mantissa-bits) mantissa) type)
|
||||
(- exponent (1- (expt 2 (1- exponent-bits))) mantissa-bits))))))))
|
||||
|
||||
(defun signed-integer-value (integer width)
|
||||
(if (= 1 (ldb (byte 1 (1- width)) integer))
|
||||
(- integer (expt 2 width))
|
||||
integer))
|
||||
118
lib/macro-utilities.lisp
Normal file
118
lib/macro-utilities.lisp
Normal file
@ -0,0 +1,118 @@
|
||||
;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; macro-utilities.lisp --- Common utilities in macro writing
|
||||
;;;;
|
||||
;;;; $Id$
|
||||
|
||||
(cl:in-package #:pmsf-lib)
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; This file contains a number of utility functions and macros which
|
||||
;;;; are useful in writing macros.
|
||||
;;;;
|
||||
|
||||
(defmacro with-unique-names ((&rest bindings) &body body)
|
||||
"Executes a series of forms with each var bound to a fresh, uninterned
|
||||
symbol. The uninterned symbol is created as if by a call to gensym with
|
||||
the string denoted by prefix -- or, if prefix is not supplied, the string
|
||||
denoted by var -- as argument.
|
||||
The variable bindings created are lexical unless special declarations are
|
||||
specified.
|
||||
The forms are evaluated in order, and the values of all but the last are
|
||||
discarded (that is, the body is an implicit progn)."
|
||||
`(let ,(mapcar #'(lambda (binding)
|
||||
(destructuring-bind (var prefix)
|
||||
(if (consp binding) binding (list binding binding))
|
||||
`(,var (gensym ,(string prefix)))))
|
||||
bindings)
|
||||
,@body))
|
||||
|
||||
(defmacro rebinding (bindings &body body)
|
||||
"Bind each var in bindings to a gensym, bind the gensym to
|
||||
var's value via a let, return body's value wrapped in this let.
|
||||
Evaluates a series of forms in the lexical environment that is
|
||||
formed by adding the binding of each var to a fresh, uninterned
|
||||
symbol, and the binding of that fresh, uninterned symbol to var's
|
||||
original value, i.e., its value in the current lexical
|
||||
environment.
|
||||
The uninterned symbol is created as if by a call to gensym with the
|
||||
string denoted by prefix -- or, if prefix is not supplied, the string
|
||||
denoted by var -- as argument.
|
||||
The forms are evaluated in order, and the values of all but the last
|
||||
are discarded (that is, the body is an implicit progn)."
|
||||
(loop for binding in bindings
|
||||
for var = (car (if (consp binding) binding (list binding)))
|
||||
for name = (gensym)
|
||||
collect `(,name ,var) into renames
|
||||
collect ``(,,var ,,name) into temps
|
||||
finally (return `(let* ,renames
|
||||
(with-unique-names ,bindings
|
||||
`(let (,,@temps)
|
||||
,,@body))))))
|
||||
|
||||
(defun symbolicate (&rest pieces)
|
||||
(intern
|
||||
(apply #'concatenate 'string
|
||||
(loop for thing in pieces
|
||||
collect (if (symbolp thing)
|
||||
(symbol-name thing)
|
||||
thing)))))
|
||||
|
||||
(defun symbolicate* (package &rest pieces)
|
||||
(intern
|
||||
(apply #'concatenate 'string
|
||||
(loop for thing in pieces
|
||||
collect (if (symbolp thing)
|
||||
(symbol-name thing)
|
||||
thing)))
|
||||
package))
|
||||
|
||||
;;; Parse-Body
|
||||
;;;
|
||||
;;; Parse out declarations and doc strings, *not* expanding macros.
|
||||
;;;
|
||||
;;; Taken from CMU CL, which is in the public domain
|
||||
;;;
|
||||
(defun parse-body (body &optional (doc-string-allowed t))
|
||||
"This function is to parse the declarations and doc-string out of the body of
|
||||
a defun-like form. Body is the list of stuff which is to be parsed.
|
||||
Environment is ignored. If Doc-String-Allowed is true, then a doc string
|
||||
will be parsed out of the body and returned. If it is false then a string
|
||||
will terminate the search for declarations. Three values are returned: the
|
||||
tail of Body after the declarations and doc strings, a list of declare forms,
|
||||
and the doc-string, or NIL if none."
|
||||
(let ((decls ())
|
||||
(doc nil))
|
||||
(do ((tail body (cdr tail)))
|
||||
((endp tail)
|
||||
(values tail (nreverse decls) doc))
|
||||
(let ((form (car tail)))
|
||||
(cond ((and (stringp form) (cdr tail))
|
||||
(if doc-string-allowed
|
||||
(setq doc form
|
||||
;; Only one doc string is allowed.
|
||||
doc-string-allowed nil)
|
||||
(return (values tail (nreverse decls) doc))))
|
||||
((not (and (consp form) (symbolp (car form))))
|
||||
(return (values tail (nreverse decls) doc)))
|
||||
((eq (car form) 'declare)
|
||||
(push form decls))
|
||||
(t
|
||||
(return (values tail (nreverse decls) doc))))))))
|
||||
|
||||
;;; Required-Argument
|
||||
;;;
|
||||
;;; Taken from CMU CL, which is in the public domain
|
||||
;;;
|
||||
(declaim (ftype (function () nil) required-argument))
|
||||
(defun required-argument ()
|
||||
"This function can be used as the default value for keyword arguments that
|
||||
must be always be supplied. Since it is known by the compiler to never
|
||||
return, it will avoid any compile-time type warnings that would result from a
|
||||
default value inconsistent with the declared type. When this function is
|
||||
called, it signals an error indicating that a required keyword argument was
|
||||
not supplied. This function is also useful for DEFSTRUCT slot defaults
|
||||
corresponding to required arguments."
|
||||
(error "A required keyword argument was not supplied."))
|
||||
161
lib/parsing-utilities.lisp
Normal file
161
lib/parsing-utilities.lisp
Normal file
@ -0,0 +1,161 @@
|
||||
;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; parsing-utilities.lisp --- Parser writing support machinery
|
||||
;;;;
|
||||
;;;; $Id$
|
||||
|
||||
(cl:in-package #:pmsf-lib)
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; This file contains various utility functions and macros for use
|
||||
;;;; when writing lexers and parsers.
|
||||
;;;;
|
||||
|
||||
;;;
|
||||
;;; Lexer Facility
|
||||
;;;
|
||||
|
||||
(define-condition lexer-error (simple-error)
|
||||
((lexer :initarg :lexer :reader lexer-error-lexer)
|
||||
(string :initarg :string :reader lexer-error-string)
|
||||
(position :initarg :position :reader lexer-error-position))
|
||||
(:report (lambda (c s)
|
||||
(format s "Lexer ~A:~D:~S: ~?"
|
||||
(lexer-error-lexer c)
|
||||
(lexer-error-position c)
|
||||
(lexer-error-string c)
|
||||
(simple-condition-format-control c)
|
||||
(simple-condition-format-arguments c)))))
|
||||
|
||||
(defmacro define-lexer (name (&rest options) &rest clauses)
|
||||
(with-unique-names (string start end)
|
||||
`(defun ,name (,string &key ((:start ,start) 0) ((:end ,end)))
|
||||
(let ((,end (or ,end (length ,string))))
|
||||
(lambda ()
|
||||
,(generate-lexer-body name string start end clauses options))))))
|
||||
|
||||
(defmacro with-lexer ((name (&rest options) &rest clauses) string &body body)
|
||||
(with-unique-names (string-var start end)
|
||||
`(let* ((,string-var ,string) (,start 0) (,end (length ,string-var)))
|
||||
(flet ((,name ()
|
||||
,(generate-lexer-body name string-var start end
|
||||
clauses options)))
|
||||
,@body))))
|
||||
|
||||
(defun generate-lexer-body (name string start end clauses options)
|
||||
(destructuring-bind (&key (regex-code-limit cl-ppcre:*regex-char-code-limit*)
|
||||
(use-bmh-matchers cl-ppcre:*use-bmh-matchers*))
|
||||
options
|
||||
(with-unique-names (match-start match-end reg-starts reg-ends)
|
||||
`(do ()
|
||||
((>= ,start ,end) nil)
|
||||
,@(loop for (pattern varlist . body) in clauses
|
||||
for real-pattern = `(:sequence :start-anchor
|
||||
,(if (stringp pattern)
|
||||
`(:regex ,pattern)
|
||||
pattern))
|
||||
collect
|
||||
`(multiple-value-bind (,match-start
|
||||
,match-end
|
||||
,reg-starts ,reg-ends)
|
||||
(cl-ppcre:scan
|
||||
(load-time-value
|
||||
(let ((cl-ppcre:*regex-char-code-limit*
|
||||
,regex-code-limit)
|
||||
(cl-ppcre:*use-bmh-matchers* ,use-bmh-matchers))
|
||||
(cl-ppcre:create-scanner ',real-pattern)))
|
||||
,string
|
||||
:start ,start :end ,end)
|
||||
(declare (ignorable ,match-end ,reg-starts ,reg-ends))
|
||||
(when (and ,match-start (= ,match-start ,start))
|
||||
(flet ((succeed (id &optional (value id))
|
||||
(setq ,start ,match-end)
|
||||
(return (values id value)))
|
||||
(skip ()
|
||||
(setq ,start ,match-end)
|
||||
(go restart))
|
||||
(fail (&optional (reason "No match!")
|
||||
&rest args)
|
||||
(error 'lexer-error
|
||||
:lexer ',name
|
||||
:position ,start
|
||||
:string ,string
|
||||
:format-control reason
|
||||
:format-arguments args)))
|
||||
(declare (ignorable #'succeed #'skip #'fail))
|
||||
(let ,(loop for var in varlist
|
||||
for index upfrom 0
|
||||
collect
|
||||
`(,var
|
||||
(when (aref ,reg-starts ,index)
|
||||
(subseq ,string
|
||||
(aref ,reg-starts ,index)
|
||||
(aref ,reg-ends ,index)))))
|
||||
,@body)))))
|
||||
(error 'lexer-error
|
||||
:lexer ',name
|
||||
:position ,start
|
||||
:string ,string
|
||||
:format-control "No match!"
|
||||
:format-arguments nil)
|
||||
restart))))
|
||||
|
||||
;;;
|
||||
;;; Parsing Helpers
|
||||
;;;
|
||||
|
||||
(defun infix-to-prefix (a b c) (list b a c))
|
||||
|
||||
;;;
|
||||
;;; Regexp replacement helpers
|
||||
;;;
|
||||
|
||||
(defun generate-replacement-template (replacement)
|
||||
(let ((result nil))
|
||||
(dolist (token (cl-ppcre::build-replacement-template replacement)
|
||||
(nreverse result))
|
||||
(let ((actual (if (eq token :backslash) "\\" token)))
|
||||
(if (and (stringp actual) (first result) (stringp (first result)))
|
||||
(push (concatenate 'string (pop result) actual) result)
|
||||
(push actual result))))))
|
||||
|
||||
(defun derive-new-pattern (target-string match-start match-end reg-starts reg-ends replacement-template)
|
||||
(loop with reg-bound = (if reg-starts (array-dimension reg-starts 0) 0)
|
||||
for token in replacement-template
|
||||
collect
|
||||
(typecase token
|
||||
(string token)
|
||||
(integer
|
||||
;; replace numbers with the corresponding registers
|
||||
(when (>= token reg-bound)
|
||||
;; but only if the register was referenced in the
|
||||
;; regular expression
|
||||
(cl-ppcre::signal-invocation-error
|
||||
"Reference to non-existent register ~A in replacement string."
|
||||
(1+ token)))
|
||||
(when (svref reg-starts token)
|
||||
;; and only if it matched, i.e. no match results
|
||||
;; in an empty string
|
||||
(cl-ppcre:quote-meta-chars
|
||||
(subseq target-string
|
||||
(svref reg-starts token)
|
||||
(svref reg-ends token)))))
|
||||
(symbol
|
||||
(case token
|
||||
((:match)
|
||||
;; the whole match
|
||||
(cl-ppcre:quote-meta-chars
|
||||
(subseq target-string match-start match-end)))
|
||||
((:before-match)
|
||||
;; the part of the target string before the match
|
||||
(cl-ppcre:quote-meta-chars
|
||||
(subseq target-string 0 match-start)))
|
||||
((:after-match)
|
||||
;; the part of the target string after the match
|
||||
(cl-ppcre:quote-meta-chars
|
||||
(subseq target-string match-end))))))
|
||||
into result
|
||||
finally (return (reduce (lambda (x y) (concatenate 'string x y)) result
|
||||
:initial-value ""))))
|
||||
571
lib/pecoff-utilities.lisp
Normal file
571
lib/pecoff-utilities.lisp
Normal file
@ -0,0 +1,571 @@
|
||||
;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; pecoff-utilities.lisp --- Utilities concerned with PE/COFF
|
||||
;;;;
|
||||
;;;; $Id$
|
||||
|
||||
(cl:in-package #:pmsf-pecoff)
|
||||
|
||||
(pmsf-lib:file-version :pmsf-lib "$Id$")
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; This file contains utilities for PE/COFF file handling
|
||||
;;;;
|
||||
|
||||
(defvar *pecoff-processing-pathname* nil)
|
||||
|
||||
(define-condition pecoff-processing-error (simple-error)
|
||||
((pathname :initarg :pathname :initform *pecoff-processing-pathname*
|
||||
:reader pecoff-processing-error-pathname))
|
||||
(:report
|
||||
(lambda (c s)
|
||||
(with-standard-io-syntax
|
||||
(let ((*print-readably* nil))
|
||||
(format s
|
||||
"Error processing PE/COFF file~@[ for ~A~]: ~?"
|
||||
(pecoff-processing-error-pathname c)
|
||||
(simple-condition-format-control c)
|
||||
(simple-condition-format-arguments c)))))))
|
||||
|
||||
(defun pecoff-processing-error (datum &rest arguments)
|
||||
(error 'pecoff-processing-error :format-control datum
|
||||
:format-arguments arguments))
|
||||
|
||||
;;;
|
||||
;;; PE/COFF Structures
|
||||
;;;
|
||||
|
||||
(defclass file ()
|
||||
((mz-stub :initarg :mz-stub :accessor file-mz-stub)
|
||||
(signature :initarg :signature :accessor file-signature)
|
||||
(header :initarg :header :accessor file-header)
|
||||
(optional-header :initarg :optional-header
|
||||
:accessor file-optional-header)
|
||||
(sections :initarg :sections :accessor file-sections)
|
||||
(raw-data :initarg :raw-data :accessor file-raw-data)))
|
||||
|
||||
(defclass mz-stub ()
|
||||
((raw-magic :initarg :raw-magic :accessor mz-stub-raw-magic)
|
||||
(pecoff-offset :initarg :pecoff-offset
|
||||
:accessor mz-stub-pecoff-offset)
|
||||
(raw-data :initarg :raw-data :accessor mz-stub-raw-data)))
|
||||
|
||||
(defconstant +header-machine-type-i386+ #x14c)
|
||||
(defconstant +header-machine-type-amd64+ #x8664)
|
||||
(defconstant +header-machine-type-arm+ #x1c0)
|
||||
(defconstant +header-machine-type-thumb+ #x1c2)
|
||||
(defconstant +header-machine-type-armnt+ #x1c4)
|
||||
(defconstant +header-machine-type-arm64+ #xaa64)
|
||||
|
||||
(defclass header ()
|
||||
((machine-type :initarg :machine-type
|
||||
:accessor header-machine-type)
|
||||
(number-of-sections :initarg :number-of-sections
|
||||
:accessor header-number-of-sections)
|
||||
(time-date-stamp :initarg :time-date-stamp
|
||||
:accessor header-time-date-stamp)
|
||||
(offset-to-symbol-table :initarg :offset-to-symbol-table
|
||||
:accessor header-offset-to-symbol-table)
|
||||
(number-of-symbols :initarg :number-of-symbols
|
||||
:accessor header-number-of-symbols)
|
||||
(size-of-optional-header :initarg :size-of-optional-header
|
||||
:accessor header-size-of-optional-header)
|
||||
(characteristics :initarg :characteristics
|
||||
:accessor header-characteristics)))
|
||||
|
||||
(defclass optional-header ()
|
||||
((linker-major-version :initarg :linker-major-version
|
||||
:accessor optional-header-linker-major-version)
|
||||
(linker-minor-version :initarg :linker-minor-version
|
||||
:accessor optional-header-linker-minor-version)
|
||||
(size-of-code :initarg :size-of-code
|
||||
:accessor optional-header-size-of-code)
|
||||
(size-of-initialized-data :initarg :size-of-initialized-data
|
||||
:accessor optional-header-size-of-initialized-data)
|
||||
(size-of-uninitialized-data :initarg :size-of-uninitialized-data
|
||||
:accessor optional-header-size-of-uninitialized-data)
|
||||
(address-of-entry-point :initarg :address-of-entry-point
|
||||
:accessor optional-header-address-of-entry-point)
|
||||
(base-of-code :initarg :base-of-code
|
||||
:accessor optional-header-base-of-code)
|
||||
;; Windows-specific part
|
||||
(image-base :initarg :image-base
|
||||
:accessor optional-header-image-base)
|
||||
(section-alignment :initarg :section-alignment
|
||||
:accessor optional-header-section-alignment)
|
||||
(file-alignment :initarg :file-alignment
|
||||
:accessor optional-header-file-alignment)
|
||||
(major-os-version :initarg :major-os-version
|
||||
:accessor optional-header-major-os-version)
|
||||
(minor-os-version :initarg :minor-os-version
|
||||
:accessor optional-header-minor-os-version)
|
||||
(major-image-version :initarg :major-image-version
|
||||
:accessor optional-header-major-image-version)
|
||||
(minor-image-version :initarg :minor-image-version
|
||||
:accessor optional-header-minor-image-version)
|
||||
(major-subsystem-version :initarg :major-subsystem-version
|
||||
:accessor optional-header-major-subsystem-version)
|
||||
(minor-subsystem-version :initarg :minor-subsystem-version
|
||||
:accessor optional-header-minor-subsystem-version)
|
||||
(win32-version-value :initarg :win32-version-value
|
||||
:accessor optional-header-win32-version-value)
|
||||
(size-of-image :initarg :size-of-image
|
||||
:accessor optional-header-size-of-image)
|
||||
(size-of-headers :initarg :size-of-headers
|
||||
:accessor optional-header-size-of-headers)
|
||||
(checksum :initarg :checksum
|
||||
:accessor optional-header-checksum)
|
||||
(subsystem :initarg :subsystem
|
||||
:accessor optional-header-subsystem)
|
||||
(dll-characteristics :initarg :dll-characteristics
|
||||
:accessor optional-header-dll-characteristics)
|
||||
(size-of-stack-reserve :initarg :size-of-stack-reserve
|
||||
:accessor optional-header-size-of-stack-reserve)
|
||||
(size-of-stack-commit :initarg :size-of-stack-commit
|
||||
:accessor optional-header-size-of-stack-commit)
|
||||
(size-of-heap-reserve :initarg :size-of-heap-reserve
|
||||
:accessor optional-header-size-of-heap-reserve)
|
||||
(size-of-heap-commit :initarg :size-of-heap-commit
|
||||
:accessor optional-header-size-of-heap-commit)
|
||||
(loader-flags :initarg :loader-flags
|
||||
:accessor optional-header-loader-flags)
|
||||
(number-of-rva-and-sizes :initarg :number-of-rva-and-sizes
|
||||
:accessor optional-header-number-of-rva-and-sizes)
|
||||
(data-directories :initarg :data-directories
|
||||
:accessor optional-header-data-directories)))
|
||||
|
||||
(defclass data-directory ()
|
||||
((virtual-address :initarg :virtual-address
|
||||
:accessor data-directory-virtual-address)
|
||||
(size :initarg :size :accessor data-directory-size)))
|
||||
|
||||
(defclass optional-header-pe32 (optional-header)
|
||||
((base-of-data :initarg :base-of-data
|
||||
:accessor optional-header-base-of-data)))
|
||||
|
||||
(defclass optional-header-pe32+ (optional-header)
|
||||
())
|
||||
|
||||
(defclass section ()
|
||||
((name :initarg :name :accessor section-name)
|
||||
(virtual-size :initarg :virtual-size :accessor section-virtual-size)
|
||||
(virtual-address :initarg :virtual-address :accessor section-virtual-address)
|
||||
(size-of-raw-data :initarg :size-of-raw-data :accessor section-size-of-raw-data)
|
||||
(pointer-to-raw-data :initarg :pointer-to-raw-data :accessor section-pointer-to-raw-data)
|
||||
(pointer-to-relocations :initarg :pointer-to-relocations :accessor section-pointer-to-relocations)
|
||||
(pointer-to-line-numbers :initarg :pointer-to-line-numbers :accessor section-pointer-to-line-numbers)
|
||||
(number-of-relocations :initarg :number-of-relocations :accessor section-number-of-relocations)
|
||||
(number-of-line-numbers :initarg :number-of-line-numbers :accessor section-number-of-line-numbers)
|
||||
(characteristics :initarg :characteristics :accessor section-characteristics)
|
||||
(raw-data :initarg :raw-data :accessor section-raw-data)))
|
||||
|
||||
(defclass export-directory ()
|
||||
((export-flags :initarg :export-flags
|
||||
:accessor export-directory-export-flags)
|
||||
(time-date-stamp :initarg :time-date-stamp
|
||||
:accessor export-directory-time-date-stamp)
|
||||
(major-version :initarg :major-version
|
||||
:accessor export-directory-major-version)
|
||||
(minor-version :initarg :minor-version
|
||||
:accessor export-directory-minor-version)
|
||||
(name-rva :initarg :name-rva
|
||||
:accessor export-directory-name-rva)
|
||||
(name :initarg :name
|
||||
:accessor export-directory-name)
|
||||
(ordinal-base :initarg :ordinal-base
|
||||
:accessor export-directory-ordinal-name)
|
||||
(address-table-entries :initarg :address-table-entries
|
||||
:accessor export-directory-address-table-entries)
|
||||
(name-table-entries :initarg :name-table-entries
|
||||
:accessor export-directory-name-table-entries)
|
||||
(address-table-rva :initarg :address-table-rva
|
||||
:accessor export-directory-address-table-rva)
|
||||
(name-table-rva :initarg :name-table-rva
|
||||
:accessor export-directory-name-table-rva)
|
||||
(ordinal-table-rva :initarg :ordinal-table-rva
|
||||
:accessor export-directory-ordinal-table-rva)
|
||||
(address-table :initarg :address-table
|
||||
:accessor export-directory-address-table)
|
||||
(name-table :initarg :name-table
|
||||
:accessor export-directory-name-table)
|
||||
(ordinal-table :initarg :ordinal-table
|
||||
:accessor export-directory-ordinal-table)
|
||||
(raw-data :initarg :raw-data
|
||||
:accessor export-directory-raw-data)))
|
||||
|
||||
;;;
|
||||
;;; Utility Accessors
|
||||
;;;
|
||||
|
||||
(defun get-string-from-rva (file address)
|
||||
(loop for section across (file-sections file)
|
||||
for start = (section-virtual-address section)
|
||||
for stop = (1- (+ start (section-virtual-size section)))
|
||||
for raw-size = (section-size-of-raw-data section)
|
||||
for raw-data = (section-raw-data section)
|
||||
thereis
|
||||
(when (and (<= start address stop)
|
||||
(<= (- address start) raw-size))
|
||||
(let ((end (position 0 raw-data :start (- address start))))
|
||||
(make-array (list (1+ (- end (- address start))))
|
||||
:element-type '(unsigned-byte 8)
|
||||
:displaced-to raw-data
|
||||
:displaced-index-offset (- address start))))))
|
||||
|
||||
(defun access-data-directory-contents (file index)
|
||||
(let* ((opt-header (file-optional-header file))
|
||||
(entry (aref (optional-header-data-directories opt-header)
|
||||
index)))
|
||||
(loop with address = (data-directory-virtual-address entry)
|
||||
with size = (data-directory-size entry)
|
||||
for section across (file-sections file)
|
||||
for start = (section-virtual-address section)
|
||||
for stop = (1- (+ start (section-virtual-size section)))
|
||||
for raw-size = (section-size-of-raw-data section)
|
||||
for raw-data = (section-raw-data section)
|
||||
thereis
|
||||
(when (and (<= start address stop)
|
||||
(<= start (1- (+ address size)) stop)
|
||||
(<= (- address start) raw-size))
|
||||
(make-array (list size)
|
||||
:element-type '(unsigned-byte 8)
|
||||
:displaced-to raw-data
|
||||
:displaced-index-offset (- address start))))))
|
||||
|
||||
;;;
|
||||
;;; Basic COFF I/O
|
||||
;;;
|
||||
|
||||
(defvar *current-source*)
|
||||
(defvar *current-offset*)
|
||||
(defvar *current-kind*)
|
||||
|
||||
(defmacro with-pecoff-reading (source &body body)
|
||||
`(let ((*current-source* ,source)
|
||||
(*current-offset* 0))
|
||||
,@body))
|
||||
|
||||
(defmacro with-pecoff-reading-kind (kind &body body)
|
||||
`(let ((*current-kind* ,kind))
|
||||
,@body))
|
||||
|
||||
(defun read-coff-byte (&optional offset)
|
||||
(when offset (setq *current-offset* offset))
|
||||
(prog1 (aref *current-source* *current-offset*)
|
||||
(incf *current-offset*)))
|
||||
|
||||
(defun read-coff-half (&optional offset)
|
||||
(let ((lsb (read-coff-byte offset)))
|
||||
(dpb (read-coff-byte) (byte 8 8) lsb)))
|
||||
|
||||
(defun read-coff-word (&optional offset)
|
||||
(let* ((lsb (read-coff-byte offset))
|
||||
(lsb2 (read-coff-byte))
|
||||
(lsb3 (read-coff-byte))
|
||||
(msb (read-coff-byte)))
|
||||
(dpb msb (byte 8 24) (dpb lsb3 (byte 8 16) (dpb lsb2 (byte 8 8) lsb)))))
|
||||
|
||||
(defun read-coff-xword (&optional offset)
|
||||
(let* ((lsb (read-coff-byte offset))
|
||||
(lsb2 (read-coff-byte))
|
||||
(lsb3 (read-coff-byte))
|
||||
(lsb4 (read-coff-byte))
|
||||
(lsb5 (read-coff-byte))
|
||||
(lsb6 (read-coff-byte))
|
||||
(lsb7 (read-coff-byte))
|
||||
(msb (read-coff-byte)))
|
||||
(dpb msb (byte 8 56)
|
||||
(dpb lsb7 (byte 8 48)
|
||||
(dpb lsb6 (byte 8 40)
|
||||
(dpb lsb5 (byte 8 32)
|
||||
(dpb lsb4 (byte 8 24)
|
||||
(dpb lsb3 (byte 8 16)
|
||||
(dpb lsb2 (byte 8 8) lsb)))))))))
|
||||
|
||||
(defun read-coff-word/xword (&optional offset)
|
||||
(ecase *current-kind*
|
||||
(:pe32 (read-coff-word offset))
|
||||
(:pe32+ (read-coff-xword offset))))
|
||||
|
||||
(defun read-coff-sequence (length &optional offset)
|
||||
(when offset (setq *current-offset* offset))
|
||||
(let ((result (make-array (list length) :element-type '(unsigned-byte 8)
|
||||
:displaced-to *current-source*
|
||||
:displaced-index-offset *current-offset*)))
|
||||
(incf *current-offset* length)
|
||||
result))
|
||||
|
||||
;;;
|
||||
;;; Header Handling and Reading
|
||||
;;;
|
||||
|
||||
(defun check-pecoff-file-p ()
|
||||
(and
|
||||
;; MZ Stub
|
||||
(eql (read-coff-byte 0) (char-code #\M))
|
||||
(eql (read-coff-byte) (char-code #\Z))
|
||||
(let ((pe-offset (read-coff-word #x3c)))
|
||||
(and
|
||||
(eql (read-coff-byte pe-offset) (char-code #\P))
|
||||
(eql (read-coff-byte) (char-code #\E))
|
||||
(eql (read-coff-byte) 0)
|
||||
(eql (read-coff-byte) 0)))))
|
||||
|
||||
(defun read-mz-stub ()
|
||||
(let ((identifier (read-coff-sequence 2 0))
|
||||
(pecoff-offset (read-coff-word #x3c)))
|
||||
(unless (every #'eql identifier (map 'list #'char-code "MZ"))
|
||||
(pecoff-processing-error "Invalid MZ MAGIC:~{ 0x~2,'0X~}"
|
||||
(coerce identifier 'list)))
|
||||
(make-instance 'mz-stub
|
||||
:raw-magic identifier
|
||||
:pecoff-offset pecoff-offset
|
||||
:raw-data
|
||||
(read-coff-sequence pecoff-offset 0))))
|
||||
|
||||
(defun read-pecoff-signature (&optional offset)
|
||||
(let ((signature (read-coff-sequence 4 offset)))
|
||||
(unless (every #'eql signature
|
||||
(map 'list #'char-code
|
||||
(list #\P #\E #\NULL #\NULL)))
|
||||
(pecoff-processing-error "Invalid PE Signature:~{ 0x~2,'0X~}"
|
||||
(coerce signature 'list)))
|
||||
signature))
|
||||
|
||||
(defun read-header (&optional offset)
|
||||
(let ((machine-type (read-coff-half offset))
|
||||
(number-of-sections (read-coff-half))
|
||||
(time-date-stamp (read-coff-word))
|
||||
(offset-to-symbol-table (read-coff-word))
|
||||
(number-of-symbols (read-coff-word))
|
||||
(size-of-optional-header (read-coff-half))
|
||||
(characteristics (read-coff-half)))
|
||||
(make-instance 'header
|
||||
:machine-type machine-type
|
||||
:number-of-sections number-of-sections
|
||||
:time-date-stamp time-date-stamp
|
||||
:offset-to-symbol-table offset-to-symbol-table
|
||||
:number-of-symbols number-of-symbols
|
||||
:size-of-optional-header size-of-optional-header
|
||||
:characteristics characteristics)))
|
||||
|
||||
(defun read-optional-header (size &optional offset)
|
||||
(unless (zerop size)
|
||||
(let ((magic (read-coff-half offset)))
|
||||
(cond
|
||||
((eql magic #x010b)
|
||||
(read-optional-header-pe32))
|
||||
((eql magic #x020b)
|
||||
(read-optional-header-pe32+))
|
||||
(t
|
||||
(pecoff-processing-error "Unsupported optional header magic 0x~4,'0X" magic))))))
|
||||
|
||||
(defun read-optional-header-pe32 ()
|
||||
(apply
|
||||
#'make-instance
|
||||
'optional-header-pe32
|
||||
:linker-major-version (read-coff-byte)
|
||||
:linker-minor-version (read-coff-byte)
|
||||
:size-of-code (read-coff-word)
|
||||
:size-of-initialized-data (read-coff-word)
|
||||
:size-of-uninitialized-data (read-coff-word)
|
||||
:address-of-entry-point (read-coff-word)
|
||||
:base-of-code (read-coff-word)
|
||||
:base-of-data (read-coff-word)
|
||||
(with-pecoff-reading-kind :pe32
|
||||
(read-optional-header-windows))))
|
||||
|
||||
(defun read-optional-header-pe32+ ()
|
||||
(apply
|
||||
#'make-instance
|
||||
'optional-header-pe32+
|
||||
:linker-major-version (read-coff-byte)
|
||||
:linker-minor-version (read-coff-byte)
|
||||
:size-of-code (read-coff-word)
|
||||
:size-of-initialized-data (read-coff-word)
|
||||
:size-of-uninitialized-data (read-coff-word)
|
||||
:address-of-entry-point (read-coff-word)
|
||||
:base-of-code (read-coff-word)
|
||||
(with-pecoff-reading-kind :pe32+
|
||||
(read-optional-header-windows))))
|
||||
|
||||
(defun read-optional-header-windows ()
|
||||
(list*
|
||||
:image-base (read-coff-word/xword)
|
||||
:section-alignment (read-coff-word)
|
||||
:file-alignment (read-coff-word)
|
||||
:major-os-version (read-coff-half)
|
||||
:minor-os-version (read-coff-half)
|
||||
:major-image-version (read-coff-half)
|
||||
:minor-image-version (read-coff-half)
|
||||
:major-subsystem-version (read-coff-half)
|
||||
:minor-subsystem-version (read-coff-half)
|
||||
:win32-version-value (read-coff-word)
|
||||
:size-of-image (read-coff-word)
|
||||
:size-of-headers (read-coff-word)
|
||||
:checksum (read-coff-word)
|
||||
:subsystem (read-coff-half)
|
||||
:dll-characteristics (read-coff-half)
|
||||
:size-of-stack-reserve (read-coff-word/xword)
|
||||
:size-of-stack-commit (read-coff-word/xword)
|
||||
:size-of-heap-reserve (read-coff-word/xword)
|
||||
:size-of-heap-commit (read-coff-word/xword)
|
||||
:loader-flags (read-coff-word)
|
||||
(let ((entries (read-coff-word)))
|
||||
(list :number-of-rva-and-sizes entries
|
||||
:data-directories
|
||||
(coerce
|
||||
(loop repeat entries
|
||||
collect
|
||||
(make-instance 'data-directory
|
||||
:virtual-address (read-coff-word)
|
||||
:size (read-coff-word)))
|
||||
'vector)))))
|
||||
|
||||
(defun read-section (&optional offset)
|
||||
(let ((result
|
||||
(make-instance
|
||||
'section
|
||||
:name (read-coff-sequence 8 offset)
|
||||
:virtual-size (read-coff-word)
|
||||
:virtual-address (read-coff-word)
|
||||
:size-of-raw-data (read-coff-word)
|
||||
:pointer-to-raw-data (read-coff-word)
|
||||
:pointer-to-relocations (read-coff-word)
|
||||
:pointer-to-line-numbers (read-coff-word)
|
||||
:number-of-relocations (read-coff-half)
|
||||
:number-of-line-numbers (read-coff-half)
|
||||
:characteristics (read-coff-word))))
|
||||
(unless (zerop (section-size-of-raw-data result))
|
||||
(let ((*current-offset* *current-offset*))
|
||||
(setf (section-raw-data result)
|
||||
(read-coff-sequence (section-size-of-raw-data result)
|
||||
(section-pointer-to-raw-data result)))))
|
||||
result))
|
||||
|
||||
;;;
|
||||
;;; Parsing of directories
|
||||
;;;
|
||||
|
||||
(defun parse-export-directory (file)
|
||||
(let ((raw-data (access-data-directory-contents file 0)))
|
||||
(with-pecoff-reading raw-data
|
||||
(let* ((export-flags (read-coff-word))
|
||||
(time-date-stamp (read-coff-word))
|
||||
(major-version (read-coff-half))
|
||||
(minor-version (read-coff-half))
|
||||
(name-rva (read-coff-word))
|
||||
(ordinal-base (read-coff-word))
|
||||
(address-table-entries (read-coff-word))
|
||||
(name-table-entries (read-coff-word))
|
||||
(address-table-rva (read-coff-word))
|
||||
(name-table-rva (read-coff-word))
|
||||
(ordinal-table-rva (read-coff-word)))
|
||||
(make-instance
|
||||
'export-directory
|
||||
:export-flags export-flags
|
||||
:time-date-stamp time-date-stamp
|
||||
:major-version major-version
|
||||
:minor-version minor-version
|
||||
:name-rva name-rva
|
||||
:ordinal-base ordinal-base
|
||||
:address-table-entries address-table-entries
|
||||
:name-table-entries name-table-entries
|
||||
:address-table-rva address-table-rva
|
||||
:name-table-rva name-table-rva
|
||||
:ordinal-table-rva ordinal-table-rva
|
||||
:raw-data raw-data
|
||||
:address-table
|
||||
(loop with result = (make-array address-table-entries)
|
||||
for i from 0 below address-table-entries
|
||||
do (setf (aref result i) (read-coff-word))
|
||||
finally (return result))
|
||||
:name-table
|
||||
(loop with result = (make-array name-table-entries)
|
||||
for i from 0 below name-table-entries
|
||||
for rva = (read-coff-word)
|
||||
do (setf (aref result i)
|
||||
(get-string-from-rva file rva))
|
||||
finally (return result))
|
||||
:ordinal-table
|
||||
(loop with result = (make-array address-table-entries)
|
||||
for i from 0 below address-table-entries
|
||||
do (setf (aref result i) (read-coff-half))
|
||||
finally (return result)))))))
|
||||
|
||||
;;;
|
||||
;;; Checksum Updates
|
||||
;;;
|
||||
|
||||
(defun calculate-checksum-offset (file)
|
||||
(+ (mz-stub-pecoff-offset (file-mz-stub file))
|
||||
4
|
||||
20
|
||||
64))
|
||||
|
||||
(defun calculate-checksum (file)
|
||||
(loop with raw-data = (file-raw-data file)
|
||||
with checksum-offset = (calculate-checksum-offset file)
|
||||
with checksum = 0
|
||||
for offset upfrom 0 below (length raw-data) by 2
|
||||
do
|
||||
(unless (<= checksum-offset offset (+ 2 checksum-offset))
|
||||
(incf checksum
|
||||
(dpb (aref raw-data (1+ offset))
|
||||
(byte 8 8)
|
||||
(aref raw-data offset)))
|
||||
(setq checksum
|
||||
(+ (ldb (byte 16 16) checksum)
|
||||
(ldb (byte 16 0) checksum))))
|
||||
finally
|
||||
(return
|
||||
(ldb (byte 32 0)
|
||||
(+
|
||||
(ldb (byte 16 0)
|
||||
(+ (ldb (byte 16 16) checksum)
|
||||
checksum))
|
||||
(length raw-data))))))
|
||||
|
||||
(defun update-checksum (file)
|
||||
(let ((raw-data (file-raw-data file))
|
||||
(checksum (calculate-checksum file))
|
||||
(offset (calculate-checksum-offset file)))
|
||||
(setf (aref raw-data offset) (ldb (byte 8 0) checksum)
|
||||
(aref raw-data (+ offset 1)) (ldb (byte 8 8) checksum)
|
||||
(aref raw-data (+ offset 2)) (ldb (byte 8 16) checksum)
|
||||
(aref raw-data (+ offset 3)) (ldb (byte 8 24) checksum))))
|
||||
|
||||
;;;
|
||||
;;; Main Entry Points
|
||||
;;;
|
||||
|
||||
(defun read-image-file (pathname)
|
||||
(with-open-file (in pathname :element-type '(unsigned-byte 8))
|
||||
(let ((raw-data (make-array (list (file-length in))
|
||||
:element-type '(unsigned-byte 8))))
|
||||
(read-sequence raw-data in)
|
||||
(with-pecoff-reading raw-data
|
||||
(unless (check-pecoff-file-p)
|
||||
(pecoff-processing-error "File is not in PE/COFF format!"))
|
||||
(let* ((mz-stub (read-mz-stub))
|
||||
(signature (read-pecoff-signature))
|
||||
(header (read-header))
|
||||
(optional-header (read-optional-header (header-size-of-optional-header header)))
|
||||
(sections (coerce
|
||||
(loop repeat (header-number-of-sections header)
|
||||
collect (read-section))
|
||||
'vector)))
|
||||
(make-instance 'file
|
||||
:mz-stub mz-stub
|
||||
:signature signature
|
||||
:header header
|
||||
:optional-header optional-header
|
||||
:sections sections
|
||||
:raw-data raw-data))))))
|
||||
|
||||
(defun write-image-file (file pathname)
|
||||
(with-open-file (out pathname :element-type '(unsigned-byte 8)
|
||||
:direction :output)
|
||||
(write-sequence (file-raw-data file) out)))
|
||||
138
lib/pipe-stream.lisp
Normal file
138
lib/pipe-stream.lisp
Normal file
@ -0,0 +1,138 @@
|
||||
;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; pipe-stream.lisp --- A pipe-stream implementation
|
||||
;;;;
|
||||
;;;; $Id$
|
||||
|
||||
(cl:in-package #:pmsf-lib)
|
||||
|
||||
(pmsf-lib:file-version :pmsf-lib "$Id$")
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; This file contains a pipe-stream implementation based on
|
||||
;;;; the LispWorks example code supplied with LispWorks 6.1.1.
|
||||
;;;; The example code this was derived from falls under the
|
||||
;;;; following copyright notice.
|
||||
;;;;
|
||||
|
||||
;;----------------------------------------------------------------------------
|
||||
;; Copyright (c) 1987--2012 LispWorks Ltd. All rights reserved.
|
||||
;;----------------------------------------------------------------------------
|
||||
|
||||
(defstruct storage-buffer
|
||||
(data "")
|
||||
(data-end 0)
|
||||
(eofp nil)
|
||||
(lock (mp:make-lock :name "Strorage Buffer Stream Lock")))
|
||||
|
||||
(defun add-to-storage-buffer (storage string start end)
|
||||
(let* ((len (- end start))
|
||||
(storage-data (storage-buffer-data storage))
|
||||
(storage-data-length (length storage-data))
|
||||
(new-data-end (+ (storage-buffer-data-end storage) len)))
|
||||
(when (> new-data-end storage-data-length)
|
||||
(mp:process-wait "Waiting for storage buffer to empty."
|
||||
#'(lambda ()
|
||||
(<= (setq new-data-end
|
||||
(+ (storage-buffer-data-end storage) len))
|
||||
storage-data-length))))
|
||||
(mp:with-lock
|
||||
((storage-buffer-lock storage))
|
||||
(replace storage-data string
|
||||
:start1 (storage-buffer-data-end storage)
|
||||
:end1 new-data-end)
|
||||
(setf (storage-buffer-data-end storage) new-data-end))))
|
||||
|
||||
(defun remove-from-storage-buffer (storage string start end)
|
||||
(flet ((readyp
|
||||
()
|
||||
(or (/= (storage-buffer-data-end storage) 0)
|
||||
(storage-buffer-eofp storage))))
|
||||
|
||||
(loop
|
||||
(mp:with-lock
|
||||
((storage-buffer-lock storage))
|
||||
(when (readyp)
|
||||
(return
|
||||
(let ((data-end (storage-buffer-data-end storage))
|
||||
(data (storage-buffer-data storage)))
|
||||
(if (> data-end 0)
|
||||
(let ((used-len (min data-end (- end start))))
|
||||
(replace string data
|
||||
:start1 start
|
||||
:end1 (+ start used-len))
|
||||
(replace data data :start1 used-len)
|
||||
(decf (storage-buffer-data-end storage) used-len)
|
||||
used-len)
|
||||
0)))))
|
||||
(mp:process-wait "Waiting for storage buffer to fill." #'readyp))))
|
||||
|
||||
(defun storage-buffer-listen (storage)
|
||||
(/= (storage-buffer-data-end storage) 0))
|
||||
|
||||
(defun storage-buffer-element-type (storage)
|
||||
(array-element-type (storage-buffer-data storage)))
|
||||
|
||||
|
||||
(defclass lisp-pipe-stream (stream:buffered-stream)
|
||||
((input-storage :initarg :input-storage :initform nil)
|
||||
(output-storage :initarg :output-storage :initform nil)))
|
||||
|
||||
(defmethod stream:stream-read-buffer ((stream lisp-pipe-stream) buffer start end)
|
||||
(with-slots (input-storage) stream
|
||||
(remove-from-storage-buffer input-storage buffer start end)))
|
||||
|
||||
(defmethod stream:stream-write-buffer ((stream lisp-pipe-stream) buffer start end)
|
||||
(with-slots (output-storage) stream
|
||||
(add-to-storage-buffer output-storage buffer start end)))
|
||||
|
||||
(defmethod close ((stream lisp-pipe-stream) &key abort)
|
||||
(declare (ignore abort))
|
||||
(with-slots (output-storage) stream
|
||||
(when output-storage
|
||||
(setf (storage-buffer-eofp output-storage) t)))
|
||||
t)
|
||||
|
||||
(defmethod stream:stream-listen ((stream lisp-pipe-stream))
|
||||
(with-slots (input-storage) stream
|
||||
(storage-buffer-listen input-storage)))
|
||||
|
||||
(defmethod stream:stream-check-eof-no-hang ((stream lisp-pipe-stream))
|
||||
(with-slots (input-storage) stream
|
||||
(and (storage-buffer-eofp input-storage)
|
||||
:eof)))
|
||||
|
||||
(defmethod stream-element-type ((stream lisp-pipe-stream))
|
||||
(with-slots (input-storage output-storage) stream
|
||||
(storage-buffer-element-type (or input-storage output-storage))))
|
||||
|
||||
(defmethod stream:stream-read-byte ((stream lisp-pipe-stream))
|
||||
(char-code (stream:stream-read-char stream)))
|
||||
|
||||
(defmethod stream:stream-write-byte ((stream lisp-pipe-stream) integer)
|
||||
(stream:stream-write-char stream (code-char integer)))
|
||||
|
||||
(defun make-lisp-pipe-pair (&key (element-type 'base-char) (size 8192) (direction :io))
|
||||
"Return two values, a pair of streams connected together. The DIRECTION argument controls the direction of the first stream, the second stream having the opposite direction. By default, both streams are bidirectional."
|
||||
(check-type direction (member :input :output :io))
|
||||
(let ((storage-1-to-2 (unless (eq direction :input)
|
||||
(make-storage-buffer
|
||||
:data (make-string size :element-type element-type))))
|
||||
(storage-2-to-1 (unless (eq direction :output)
|
||||
(make-storage-buffer
|
||||
:data (make-string size :element-type element-type)))))
|
||||
(values (make-instance 'lisp-pipe-stream
|
||||
:direction direction
|
||||
:input-storage storage-2-to-1
|
||||
:output-storage storage-1-to-2
|
||||
:element-type element-type)
|
||||
(make-instance 'lisp-pipe-stream
|
||||
:direction (case direction
|
||||
(:input :output)
|
||||
(:output :input)
|
||||
(otherwise direction))
|
||||
:input-storage storage-1-to-2
|
||||
:output-storage storage-2-to-1
|
||||
:element-type element-type))))
|
||||
262
lib/pkgdef.lisp
Normal file
262
lib/pkgdef.lisp
Normal file
@ -0,0 +1,262 @@
|
||||
;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; pkgdef.lisp --- Package Definition for PMSF-Lib
|
||||
;;;;
|
||||
;;;; $Id$
|
||||
|
||||
(cl:in-package #:cl-user)
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; Package Definition of PMSF-Lib
|
||||
;;;;
|
||||
|
||||
(defpackage #:pmsf-lib
|
||||
(:documentation
|
||||
"PMSF Utility package by Pierre R. Mai. See documentation for terms.")
|
||||
(:use #:common-lisp)
|
||||
(:export
|
||||
;; doc.lisp
|
||||
#:file-version #:*file-versions*
|
||||
#:get-file-versions #:list-file-versions
|
||||
#:list-file-checksums #:list-source-checksums
|
||||
#:md5-file-versions
|
||||
;; common-utilities.lisp
|
||||
#:generate-printed-guid
|
||||
;; float-utilities.lisp
|
||||
#:single-float-positive-infinity
|
||||
#:single-float-negative-infinity
|
||||
#:single-float-nan
|
||||
#:double-float-positive-infinity
|
||||
#:double-float-negative-infinity
|
||||
#:double-float-nan
|
||||
#:float-infinity-p
|
||||
#:float-nan-p
|
||||
#:float-denormalized-p
|
||||
#:bit-decode-float
|
||||
#:ieee-decode-float
|
||||
#:float-equal
|
||||
#:read-double-float-from-string
|
||||
#:read-single-float-from-string
|
||||
#:write-float
|
||||
#:float-integer-value
|
||||
#:write-hex
|
||||
#:pprint-float
|
||||
#:integer-float-value
|
||||
#:signed-integer-value
|
||||
;; macro-utilities.lisp
|
||||
#:with-unique-names #:rebinding #:symbolicate #:symbolicate*
|
||||
#:parse-body #:required-argument
|
||||
;; time-utilities.lisp
|
||||
#:format-iso8601-time
|
||||
#:define-iso8601-time-format
|
||||
#:list-iso8601-time-formats
|
||||
#:query-performance-counter
|
||||
#:query-performance-frequency
|
||||
;; parsing-utilities.lisp
|
||||
#:lexer-error
|
||||
#:lexer-error-lexer
|
||||
#:lexer-error-string
|
||||
#:lexer-error-position
|
||||
#:define-lexer
|
||||
#:with-lexer
|
||||
#:succeed
|
||||
#:skip
|
||||
#:fail
|
||||
#:infix-to-prefix
|
||||
#:generate-replacement-template
|
||||
#:derive-new-pattern
|
||||
;; printf.lisp
|
||||
#:make-printf-format-parser
|
||||
;; cmdline-utilities.lisp
|
||||
#:get-command-line-arguments
|
||||
#:command-line-argument-error
|
||||
#:command-line-argument-error-command-line
|
||||
#:command-line-argument-error-remaining-arguments
|
||||
#:parse-command-line-arguments
|
||||
#:parse-command-line-for-argument-list
|
||||
#:call-with-parsed-arguments
|
||||
#:call-with-parsed-command-line
|
||||
#:with-parsed-arguments
|
||||
#:with-parsed-command-line
|
||||
#:&program
|
||||
;; zip-utilities.lisp
|
||||
#:zip-processing-warning
|
||||
#:zip-processing-warning-pathname
|
||||
#:zip-processing-error
|
||||
#:zip-processing-error-pathname
|
||||
#:is-zip-archive-p
|
||||
#:read-zip-archive
|
||||
#:zip-archive
|
||||
#:zip-archive-p
|
||||
#:zip-archive-entries
|
||||
#:zip-entry
|
||||
#:zip-entry-p
|
||||
#:zip-entry-file-name
|
||||
#:zip-entry-file-date
|
||||
#:zip-entry-file-comment
|
||||
#:zip-entry-file-offset
|
||||
#:zip-entry-compression-method
|
||||
#:zip-entry-crc-32
|
||||
#:zip-entry-compressed-size
|
||||
#:zip-entry-uncompressed-size
|
||||
#:unzip-zip-entry-to-stream
|
||||
#:unzip-zip-archive
|
||||
;; aes-utilities.lisp
|
||||
#:aes-processing-error
|
||||
#:aes-processing-error-pathname
|
||||
#:aes-encode-buffer
|
||||
#:aes-encode-file
|
||||
#:aes-decode-buffer
|
||||
#:aes-decode-file
|
||||
;; pipe-stream.lisp
|
||||
#:lisp-pipe-stream
|
||||
#:make-lisp-pipe-pair))
|
||||
|
||||
(defpackage #:pmsf-mop
|
||||
(:documentation
|
||||
"PMSF Utility package by Pierre R. Mai. See documentation for terms.")
|
||||
(:import-from
|
||||
#+sbcl #:sb-mop #+lispworks #:clos
|
||||
.
|
||||
#1=(;; Direct class accessors
|
||||
#:class-default-initargs
|
||||
#:class-direct-default-initargs
|
||||
#:class-direct-slots
|
||||
#:class-direct-subclasses
|
||||
#:class-direct-superclasses
|
||||
#:class-finalized-p
|
||||
#:class-precedence-list
|
||||
#:class-prototype
|
||||
#:class-slots
|
||||
;; Finalization
|
||||
#:finalize-inheritance
|
||||
#:validate-superclass
|
||||
;; Slot-Definition accessors
|
||||
#:slot-definition-allocation
|
||||
#:slot-definition-initargs
|
||||
#:slot-definition-initform
|
||||
#:slot-definition-initfunction
|
||||
#:slot-definition-location
|
||||
#:slot-definition-name
|
||||
#:slot-definition-readers
|
||||
#:slot-definition-writers
|
||||
#:slot-definition-type
|
||||
#:direct-slot-definition-class
|
||||
#:effective-slot-definition-class
|
||||
;; Slot accessors
|
||||
#:slot-value-using-class
|
||||
#:slot-boundp-using-class
|
||||
#:slot-makunbound-using-class))
|
||||
(:export
|
||||
.
|
||||
#1#))
|
||||
|
||||
(defpackage #:pmsf-pecoff
|
||||
(:documentation
|
||||
"PMSF PE/COFF Utility package by Pierre R. Mai. See documentation for terms.")
|
||||
(:nicknames #:pecoff)
|
||||
(:use #:common-lisp #:pmsf-lib)
|
||||
(:export
|
||||
;; Conditions
|
||||
#:pecoff-processing-error
|
||||
#:pecoff-processing-error-pathname
|
||||
;; Structures
|
||||
#:file
|
||||
#:file-mz-stub
|
||||
#:file-signature
|
||||
#:file-header
|
||||
#:file-optional-header
|
||||
#:file-sections
|
||||
#:file-raw-data
|
||||
#:mz-stub
|
||||
#:mz-stub-raw-magic
|
||||
#:mz-stub-pecoff-offset
|
||||
#:mz-stub-raw-data
|
||||
#:+header-machine-type-i386+
|
||||
#:+header-machine-type-amd64+
|
||||
#:+header-machine-type-arm+
|
||||
#:+header-machine-type-thumb+
|
||||
#:+header-machine-type-armnt+
|
||||
#:+header-machine-type-arm64+
|
||||
#:header
|
||||
#:header-machine-type
|
||||
#:header-number-of-sections
|
||||
#:header-time-date-stamp
|
||||
#:header-offset-to-symbol-table
|
||||
#:header-number-of-symbols
|
||||
#:header-size-of-optional-header
|
||||
#:header-characteristics
|
||||
#:optional-header
|
||||
#:optional-header-linker-major-version
|
||||
#:optional-header-linker-minor-version
|
||||
#:optional-header-size-of-code
|
||||
#:optional-header-size-of-initialized-data
|
||||
#:optional-header-size-of-uninitialized-data
|
||||
#:optional-header-address-of-entry-point
|
||||
#:optional-header-base-of-code
|
||||
#:optional-header-image-base
|
||||
#:optional-header-section-alignment
|
||||
#:optional-header-file-alignment
|
||||
#:optional-header-major-os-version
|
||||
#:optional-header-minor-os-version
|
||||
#:optional-header-major-image-version
|
||||
#:optional-header-minor-image-version
|
||||
#:optional-header-major-subsystem-version
|
||||
#:optional-header-minor-subsystem-version
|
||||
#:optional-header-win32-version-value
|
||||
#:optional-header-size-of-image
|
||||
#:optional-header-size-of-headers
|
||||
#:optional-header-checksum
|
||||
#:optional-header-subsystem
|
||||
#:optional-header-dll-characteristics
|
||||
#:optional-header-size-of-stack-reserve
|
||||
#:optional-header-size-of-stack-commit
|
||||
#:optional-header-size-of-heap-reserve
|
||||
#:optional-header-size-of-heap-commit
|
||||
#:optional-header-loader-flags
|
||||
#:optional-header-number-of-rva-and-sizes
|
||||
#:optional-header-data-directories
|
||||
#:data-directory
|
||||
#:data-directory-virtual-address
|
||||
#:data-directory-size
|
||||
#:optional-header-pe32
|
||||
#:optional-header-base-of-data
|
||||
#:optional-header-pe32+
|
||||
#:section
|
||||
#:section-name
|
||||
#:section-virtual-size
|
||||
#:section-virtual-address
|
||||
#:section-size-of-raw-data
|
||||
#:section-pointer-to-raw-data
|
||||
#:section-pointer-to-relocations
|
||||
#:section-pointer-to-line-numbers
|
||||
#:section-number-of-relocations
|
||||
#:section-number-of-line-numbers
|
||||
#:section-characteristics
|
||||
#:section-raw-data
|
||||
#:export-directory
|
||||
#:export-directory-export-flags
|
||||
#:export-directory-time-date-stamp
|
||||
#:export-directory-major-version
|
||||
#:export-directory-minor-version
|
||||
#:export-directory-name-rva
|
||||
#:export-directory-name
|
||||
#:export-directory-ordinal-name
|
||||
#:export-directory-address-table-entries
|
||||
#:export-directory-name-table-entries
|
||||
#:export-directory-address-table-rva
|
||||
#:export-directory-name-table-rva
|
||||
#:export-directory-ordinal-table-rva
|
||||
#:export-directory-address-table
|
||||
#:export-directory-name-table
|
||||
#:export-directory-ordinal-table
|
||||
#:export-directory-raw-data
|
||||
;; Parsing of Additional Information
|
||||
#:get-string-from-rva
|
||||
#:access-data-directory-contents
|
||||
#:parse-export-directory
|
||||
;; I/O
|
||||
#:read-image-file
|
||||
#:write-image-file))
|
||||
89
lib/printf.lisp
Normal file
89
lib/printf.lisp
Normal file
@ -0,0 +1,89 @@
|
||||
;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; printf.lisp --- C printf parsing routines
|
||||
;;;;
|
||||
;;;; $Id$
|
||||
|
||||
(cl:in-package #:pmsf-lib)
|
||||
|
||||
(pmsf-lib:file-version :pmsf-lib "$Id$")
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; This file contains a parser for C-style printf format
|
||||
;;;; strings.
|
||||
;;;;
|
||||
|
||||
(defun make-printf-format-parser (string)
|
||||
(with-lexer (scan ()
|
||||
("%([-+ #0]+)?([1-9][0-9]*)?([.][0-9]*)?(hh|h|ll|l|L|z|j|t)?([diufFeEgGxXoscp%])"
|
||||
(flags width precision length type)
|
||||
(declare (ignore length))
|
||||
(let ((width (when width (ignore-errors (parse-integer width))))
|
||||
(precision (when precision (ignore-errors (parse-integer precision :start 1))))
|
||||
(type (char type 0)))
|
||||
(ecase type
|
||||
(#\% (succeed :literal "%"))
|
||||
((#\e #\E)
|
||||
(succeed :double-float
|
||||
(lambda (val)
|
||||
(format nil
|
||||
(if (member #\+ flags) "~v,v,,,,v,v@E" "~v,v,,,,v,vE")
|
||||
width precision (if (member #\0 flags) #\0 #\Space)
|
||||
(if (upper-case-p type) #\E #\e)
|
||||
val))))
|
||||
((#\f #\F)
|
||||
(succeed :double-float
|
||||
(lambda (val)
|
||||
(format nil
|
||||
(if (member #\+ flags) "~v,v,,,v@F" "~v,v,,,vF")
|
||||
width precision (if (member #\0 flags) #\0 #\Space)
|
||||
val))))
|
||||
((#\g #\G)
|
||||
(succeed :double-float
|
||||
(lambda (val)
|
||||
(format nil
|
||||
(if (member #\+ flags) "~v,v,,,,v,v@G" "~v,v,,,,v,vG")
|
||||
width precision (if (member #\0 flags) #\0 #\Space)
|
||||
(if (upper-case-p type) #\E #\e)
|
||||
val))))
|
||||
((#\d #\i #\u)
|
||||
(succeed (if (char= type #\u) :unsigned :signed)
|
||||
(lambda (val)
|
||||
(format nil (if (member #\+ flags) "~v,v@D" "~v,vD")
|
||||
width (if (member #\0 flags) #\0 #\Space)
|
||||
val))))
|
||||
((#\x #\X)
|
||||
(succeed :unsigned
|
||||
(lambda (val)
|
||||
(format nil (if (char= type #\X) "~:@(~v,vX~)" "~(~v,vX~)")
|
||||
width (if (member #\0 flags) #\0 #\Space)
|
||||
val))))
|
||||
((#\o)
|
||||
(succeed :unsigned
|
||||
(lambda (val)
|
||||
(format nil "~v,vO"
|
||||
width (if (member #\0 flags) #\0 #\Space)
|
||||
val))))
|
||||
(#\s
|
||||
(succeed :string
|
||||
(lambda (val)
|
||||
(format nil "~v@A"
|
||||
width
|
||||
(if precision
|
||||
(subseq val 0 (min (length val) precision))
|
||||
val)))))
|
||||
(#\c
|
||||
(succeed :char
|
||||
(lambda (val)
|
||||
(format nil "~A" val))))
|
||||
(#\p
|
||||
(succeed :pointer
|
||||
(lambda (val)
|
||||
(format nil "~8,'0X" val)))))))
|
||||
("([^%]+)"
|
||||
(str)
|
||||
(succeed :literal str)))
|
||||
string
|
||||
#'scan))
|
||||
156
lib/time-utilities.lisp
Normal file
156
lib/time-utilities.lisp
Normal file
@ -0,0 +1,156 @@
|
||||
;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; time-utilities.lisp --- Utilities concerned with time processing
|
||||
;;;;
|
||||
;;;; $Id$
|
||||
|
||||
(cl:in-package #:pmsf-lib)
|
||||
|
||||
(pmsf-lib:file-version :pmsf-lib "$Id$")
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; This file contains utilities for time processing, especially time
|
||||
;;;; formatting.
|
||||
;;;;
|
||||
|
||||
(defvar *defined-iso8601-time-formats* (make-hash-table :test #'eq))
|
||||
|
||||
(defun format-iso8601-time (&key
|
||||
(time (get-universal-time))
|
||||
(format :human))
|
||||
"Format time, which defaults to the current time as returned by
|
||||
`get-universal-time' in a string that is more or less formatted according
|
||||
to ISO8601. The exact format can be specified by the `format' parameter,
|
||||
which must be a format defined by `define-iso8601-time-format'. The list
|
||||
of currently defined formats can be displayed with the function
|
||||
`list-iso8601-time-formats'. The following set of formats are currently
|
||||
pre-defined:
|
||||
|
||||
:human YYYY-MM-DD HH:mm:ss [+|-]HH:mm
|
||||
:human-short YYYY-MM-DD HH:mm:ss
|
||||
:strict YYYY-MM-DD'T'HH:mm:ss[+|-]HH:mm
|
||||
:strict-short YYYY-MM-DD'T'HH:mm:ss
|
||||
:date YYYY-MM-DD
|
||||
:time HH:mm:ss
|
||||
:timezone [+|-]HH:mm"
|
||||
(multiple-value-bind (second minute hour date month year day daylight-p zone)
|
||||
(decode-universal-time time)
|
||||
(declare (ignore day))
|
||||
(multiple-value-bind (tz-hours tz-minutes) (truncate (- zone))
|
||||
(let ((formatter (gethash format *defined-iso8601-time-formats* nil)))
|
||||
(unless formatter
|
||||
(error "Undefined time format ~S in call to format-iso8601-time."
|
||||
format))
|
||||
(funcall formatter year month date hour minute second
|
||||
(if (minusp tz-hours) #\- #\+)
|
||||
(abs (+ tz-hours (if daylight-p 1 0)))
|
||||
(abs (* tz-minutes 60)))))))
|
||||
|
||||
(eval-when (:compile-toplevel :load-toplevel :execute)
|
||||
(defmacro define-iso8601-time-format (name (&rest vars) &body body)
|
||||
"Define a new time format named `name' with the given formatter. The
|
||||
formatter must take the following 9 parameters in the given order via
|
||||
`vars' and must return a string with the formatted time according to
|
||||
the format. It should not have any side-effects.
|
||||
|
||||
Parameters:
|
||||
- year
|
||||
- month
|
||||
- day-of-month
|
||||
- hour
|
||||
- minute
|
||||
- second
|
||||
- sign of timezone as a character + or - indicating east and west of UTC
|
||||
- hours of the timezone
|
||||
- minutes of the timezone"
|
||||
`(ensure-iso8601-time-format ',name (lambda (,@vars) ,@body))))
|
||||
|
||||
(defun list-iso8601-time-formats (&optional (time (get-universal-time)))
|
||||
"Print a list of currently defined formats and their effect on formatting
|
||||
the time given in `time', which defaults to the current time as returned by
|
||||
`get-universal-time'."
|
||||
(let ((formats (loop for key being the hash-keys of
|
||||
*defined-iso8601-time-formats*
|
||||
collect key)))
|
||||
(loop for format in (sort formats #'string< :key #'symbol-name)
|
||||
for result = (format-iso8601-time :time time :format format)
|
||||
initially
|
||||
(format t "~&~25A ~A~2%" "Format" "Formatted Time")
|
||||
do
|
||||
(format t "~25S ~A~%" format result))))
|
||||
|
||||
(defun ensure-iso8601-time-format (name formatter)
|
||||
(setf (gethash name *defined-iso8601-time-formats*) formatter))
|
||||
|
||||
(define-iso8601-time-format :human
|
||||
(year month date hour minute second tz-sign tz-hours tz-minutes)
|
||||
(format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D ~C~2,'0D:~2,'0D"
|
||||
year month date hour minute second tz-sign tz-hours tz-minutes))
|
||||
|
||||
(define-iso8601-time-format :strict
|
||||
(year month date hour minute second tz-sign tz-hours tz-minutes)
|
||||
(format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D~C~2,'0D:~2,'0D"
|
||||
year month date hour minute second tz-sign tz-hours tz-minutes))
|
||||
|
||||
(define-iso8601-time-format :human-short
|
||||
(year month date hour minute second tz-sign tz-hours tz-minutes)
|
||||
(declare (ignore tz-sign tz-hours tz-minutes))
|
||||
(format nil "~4,'0D-~2,'0D-~2,'0D ~2,'0D:~2,'0D:~2,'0D"
|
||||
year month date hour minute second))
|
||||
|
||||
(define-iso8601-time-format :strict-short
|
||||
(year month date hour minute second tz-sign tz-hours tz-minutes)
|
||||
(declare (ignore tz-sign tz-hours tz-minutes))
|
||||
(format nil "~4,'0D-~2,'0D-~2,'0DT~2,'0D:~2,'0D:~2,'0D"
|
||||
year month date hour minute second))
|
||||
|
||||
(define-iso8601-time-format :date
|
||||
(year month date hour minute second tz-sign tz-hours tz-minutes)
|
||||
(declare (ignore hour minute second tz-sign tz-hours tz-minutes))
|
||||
(format nil "~4,'0D-~2,'0D-~2,'0D" year month date))
|
||||
|
||||
(define-iso8601-time-format :time
|
||||
(year month date hour minute second tz-sign tz-hours tz-minutes)
|
||||
(declare (ignore year month date tz-sign tz-hours tz-minutes))
|
||||
(format nil "~2,'0D:~2,'0D:~2,'0D" hour minute second))
|
||||
|
||||
(define-iso8601-time-format :timezone
|
||||
(year month date hour minute second tz-sign tz-hours tz-minutes)
|
||||
(declare (ignore year month date hour minute second))
|
||||
(format nil "~C~2,'0D:~2,'0D" tz-sign tz-hours tz-minutes))
|
||||
|
||||
;;;
|
||||
;;; Access To High Precision Timers
|
||||
;;;
|
||||
|
||||
#+(and lispworks win32)
|
||||
(fli:define-foreign-function (%query-performance-counter "QueryPerformanceCounter")
|
||||
(&optional (counter (:reference-return :int64)))
|
||||
:result-type :int
|
||||
:calling-convention :stdcall)
|
||||
|
||||
#+(and lispworks win32)
|
||||
(fli:define-foreign-function (%query-performance-frequency "QueryPerformanceFrequency")
|
||||
(&optional (freq (:reference-return :int64)))
|
||||
:result-type :int
|
||||
:calling-convention :stdcall)
|
||||
|
||||
(defun query-performance-counter ()
|
||||
#+(and lispworks win32)
|
||||
(multiple-value-bind (good counter)
|
||||
(%query-performance-counter)
|
||||
(unless (zerop good)
|
||||
counter))
|
||||
#-(and lispworks win32)
|
||||
(get-internal-real-time))
|
||||
|
||||
(defun query-performance-frequency ()
|
||||
#+(and lispworks win32)
|
||||
(multiple-value-bind (good freq)
|
||||
(%query-performance-frequency)
|
||||
(unless (zerop good)
|
||||
freq))
|
||||
#-(and lispworks win32)
|
||||
internal-time-units-per-second)
|
||||
345
lib/zip-utilities.lisp
Normal file
345
lib/zip-utilities.lisp
Normal file
@ -0,0 +1,345 @@
|
||||
;;;; PMSF-Lib --- PMSF Common Lisp Utility Library
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; zip-utilities.lisp --- Utilities concerned with ZIP archives
|
||||
;;;;
|
||||
;;;; $Id$
|
||||
|
||||
(cl:in-package #:pmsf-lib)
|
||||
|
||||
(pmsf-lib:file-version :pmsf-lib "$Id$")
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; This file contains utilities for ZIP archive processing.
|
||||
;;;;
|
||||
|
||||
(defvar *zip-processing-pathname*)
|
||||
|
||||
(define-condition zip-processing-warning (simple-warning)
|
||||
((pathname :initarg :pathname :initform *zip-processing-pathname*
|
||||
:reader zip-processing-warning-pathname))
|
||||
(:report
|
||||
(lambda (c s)
|
||||
(with-standard-io-syntax
|
||||
(let ((*print-readably* nil))
|
||||
(format s
|
||||
"Warning processing ZIP archive ~A: ~?"
|
||||
(zip-processing-warning-pathname c)
|
||||
(simple-condition-format-control c)
|
||||
(simple-condition-format-arguments c)))))))
|
||||
|
||||
(define-condition zip-processing-error (simple-error)
|
||||
((pathname :initarg :pathname :initform *zip-processing-pathname*
|
||||
:reader zip-processing-error-pathname))
|
||||
(:report
|
||||
(lambda (c s)
|
||||
(with-standard-io-syntax
|
||||
(let ((*print-readably* nil))
|
||||
(format s
|
||||
"Error processing ZIP archive ~A: ~?"
|
||||
(zip-processing-error-pathname c)
|
||||
(simple-condition-format-control c)
|
||||
(simple-condition-format-arguments c)))))))
|
||||
|
||||
(defun zip-processing-error (datum &rest arguments)
|
||||
(error 'zip-processing-error :format-control datum :format-arguments arguments))
|
||||
|
||||
(defun zip-processing-warn (datum &rest arguments)
|
||||
(warn 'zip-processing-warning :format-control datum :format-arguments arguments))
|
||||
|
||||
(defun read-zip-field (stream length)
|
||||
(ecase length
|
||||
(1 (read-byte stream))
|
||||
(2 (let ((low (read-byte stream)))
|
||||
(dpb (read-byte stream) (byte 8 8) low)))
|
||||
(4 (let* ((low (read-byte stream))
|
||||
(mid1 (read-byte stream))
|
||||
(mid2 (read-byte stream)))
|
||||
(dpb (read-byte stream) (byte 8 24)
|
||||
(dpb mid2 (byte 8 16)
|
||||
(dpb mid1 (byte 8 8)
|
||||
low)))))))
|
||||
|
||||
(defun ensure-zip-signature (stream signature)
|
||||
(let ((read-signature (read-zip-field stream 4)))
|
||||
(unless (= signature read-signature)
|
||||
(zip-processing-error
|
||||
"Expected Record Signature ~8,'0X, but got ~8,'0X instead!"
|
||||
signature read-signature))
|
||||
read-signature))
|
||||
|
||||
(defmacro define-zip-record (name signature &rest fields)
|
||||
(loop with package = (symbol-package name)
|
||||
with constructor-name = (symbolicate* package '#:make- name)
|
||||
with reader-name = (symbolicate* package '#:read- name)
|
||||
with size-name = (symbolicate* package name '#:-size)
|
||||
for (field-name field-size) in fields
|
||||
collect field-name into field-names
|
||||
collect (intern (symbol-name field-name) (find-package "KEYWORD"))
|
||||
into field-keys
|
||||
collect field-size into field-sizes
|
||||
sum field-size into total-size
|
||||
finally
|
||||
(return
|
||||
`(progn
|
||||
(defstruct ,name
|
||||
,@field-names)
|
||||
(defun ,reader-name (stream)
|
||||
(ensure-zip-signature stream ,signature)
|
||||
(,constructor-name
|
||||
,@(loop for field-key in field-keys
|
||||
for field-size in field-sizes
|
||||
nconcing
|
||||
(list field-key `(read-zip-field stream ,field-size)))))
|
||||
(defconstant ,size-name ,(+ 4 total-size))))))
|
||||
|
||||
(define-zip-record zip-end-of-central-directory-record #x06054b50
|
||||
(disk-no-this-disk 2)
|
||||
(disk-no-central-directory 2)
|
||||
(entries-this-disk 2)
|
||||
(total-entries 2)
|
||||
(size 4)
|
||||
(offset 4)
|
||||
(file-comment-length 2))
|
||||
|
||||
(define-zip-record zip-central-directory-record #x02014b50
|
||||
(version-made-by 2)
|
||||
(version-needed 2)
|
||||
(general-purpose 2)
|
||||
(compression-method 2)
|
||||
(last-mod-file-time 2)
|
||||
(last-mod-file-date 2)
|
||||
(crc-32 4)
|
||||
(compressed-size 4)
|
||||
(uncompressed-size 4)
|
||||
(file-name-length 2)
|
||||
(extra-field-length 2)
|
||||
(file-comment-length 2)
|
||||
(disk-number-start 2)
|
||||
(internal-file-attributes 2)
|
||||
(external-file-attributes 4)
|
||||
(relative-offset-local-header 4))
|
||||
|
||||
(define-zip-record zip-local-file-header-record #x04034b50
|
||||
(version-needed 2)
|
||||
(general-purpose 2)
|
||||
(compression-method 2)
|
||||
(last-mod-file-time 2)
|
||||
(last-mod-file-date 2)
|
||||
(crc-32 4)
|
||||
(compressed-size 4)
|
||||
(uncompressed-size 4)
|
||||
(file-name-length 2)
|
||||
(extra-field-length 2))
|
||||
|
||||
(defun find-zip-end-of-central-directory-record (stream)
|
||||
(let* ((buffer (make-array (+ 65536 zip-end-of-central-directory-record-size)
|
||||
:element-type '(unsigned-byte 8)))
|
||||
(file-length (file-length stream))
|
||||
(file-start (max 0 (- file-length (length buffer)))))
|
||||
(file-position stream file-start)
|
||||
(loop with end = (read-sequence buffer stream)
|
||||
for start = (search #(#x50 #x4b #x05 #x06) buffer :start2 0 :end2 end)
|
||||
then (search #(#x50 #x4b #x05 #x06) buffer :start2 (1+ start) :end2 end)
|
||||
while start
|
||||
do
|
||||
(when (and (<= (+ start zip-end-of-central-directory-record-size)
|
||||
(length buffer))
|
||||
(= (+ file-start
|
||||
start
|
||||
zip-end-of-central-directory-record-size
|
||||
(dpb (aref buffer (+ start 21))
|
||||
(byte 8 8)
|
||||
(aref buffer (+ start 20))))
|
||||
file-length))
|
||||
(file-position stream (+ file-start start))
|
||||
(return t)))))
|
||||
|
||||
(defstruct zip-archive
|
||||
entries)
|
||||
|
||||
(defstruct zip-entry
|
||||
file-name
|
||||
file-date
|
||||
file-comment
|
||||
file-offset
|
||||
compression-method
|
||||
crc-32
|
||||
compressed-size
|
||||
uncompressed-size)
|
||||
|
||||
(defun zip-entry-directory-p (entry)
|
||||
(let ((last (char (zip-entry-file-name entry)
|
||||
(1- (length (zip-entry-file-name entry))))))
|
||||
(or (char= last #\/) (char= last #\\))))
|
||||
|
||||
(defun is-zip-archive-p (pathname)
|
||||
(let ((*zip-processing-pathname* (pathname pathname)))
|
||||
(handler-bind ((zip-processing-error
|
||||
(lambda (c)
|
||||
(declare (ignore c))
|
||||
(return-from is-zip-archive-p nil))))
|
||||
(with-open-file (stream pathname :element-type '(unsigned-byte 8))
|
||||
(when (find-zip-end-of-central-directory-record stream)
|
||||
(let ((end-record (read-zip-end-of-central-directory-record stream)))
|
||||
(zerop
|
||||
(zip-end-of-central-directory-record-disk-no-this-disk
|
||||
end-record))))))))
|
||||
|
||||
(defun read-zip-archive (pathname)
|
||||
(let ((*zip-processing-pathname* (pathname pathname)))
|
||||
(with-open-file (stream pathname :element-type '(unsigned-byte 8))
|
||||
(unless (find-zip-end-of-central-directory-record stream)
|
||||
(zip-processing-error
|
||||
"Did not locate end of central directory record, not a ZIP archive."))
|
||||
(let ((end-record (read-zip-end-of-central-directory-record stream)))
|
||||
(file-position stream
|
||||
(zip-end-of-central-directory-record-offset end-record))
|
||||
(loop repeat (zip-end-of-central-directory-record-total-entries end-record)
|
||||
for raw = (read-zip-central-directory-record stream)
|
||||
for name = (make-array
|
||||
(zip-central-directory-record-file-name-length raw)
|
||||
:element-type '(unsigned-byte 8))
|
||||
do
|
||||
(read-sequence name stream)
|
||||
(file-position
|
||||
stream
|
||||
(+ (file-position stream)
|
||||
(zip-central-directory-record-extra-field-length raw)
|
||||
(zip-central-directory-record-file-comment-length raw)))
|
||||
collect
|
||||
(make-zip-entry
|
||||
:file-name
|
||||
(external-format:decode-external-string
|
||||
name
|
||||
(if (zerop
|
||||
(ldb (byte 1 11)
|
||||
(zip-central-directory-record-general-purpose raw)))
|
||||
#+mswindows '(win32:code-page :id 437)
|
||||
#-mswindows :latin-1-safe
|
||||
:utf-8))
|
||||
:file-date
|
||||
(let ((date (zip-central-directory-record-last-mod-file-date raw))
|
||||
(time (zip-central-directory-record-last-mod-file-time raw)))
|
||||
(encode-universal-time (min 59 (* 2 (ldb (byte 5 0) time)))
|
||||
(min 59 (ldb (byte 6 5) time))
|
||||
(min 23 (ldb (byte 5 11) time))
|
||||
(min 31 (max 1 (ldb (byte 5 0) date)))
|
||||
(min 12 (max 1 (ldb (byte 4 5) date)))
|
||||
(+ 1980 (ldb (byte 7 9) date))))
|
||||
:file-offset
|
||||
(zip-central-directory-record-relative-offset-local-header raw)
|
||||
:compression-method
|
||||
(case (zip-central-directory-record-compression-method raw)
|
||||
(0 :stored)
|
||||
(1 :shrunk)
|
||||
(2 :reduced1)
|
||||
(3 :reduced2)
|
||||
(4 :reduced3)
|
||||
(5 :reduced4)
|
||||
(6 :imploded)
|
||||
(7 :tokenized)
|
||||
(8 :deflated)
|
||||
(9 :deflated64)
|
||||
(10 :dcl-imploded)
|
||||
(12 :bzip2)
|
||||
(14 :lzma)
|
||||
(18 :terse)
|
||||
(19 :lz77)
|
||||
(97 :wavpack)
|
||||
(98 :ppmd)
|
||||
(t (zip-central-directory-record-compression-method raw)))
|
||||
:crc-32
|
||||
(zip-central-directory-record-crc-32 raw)
|
||||
:compressed-size
|
||||
(zip-central-directory-record-compressed-size raw)
|
||||
:uncompressed-size
|
||||
(zip-central-directory-record-uncompressed-size raw))
|
||||
into entries
|
||||
finally (return (make-zip-archive :entries entries)))))))
|
||||
|
||||
(defun unzip-zip-entry-from-stream-to-stream (stream entry output)
|
||||
(file-position stream (zip-entry-file-offset entry))
|
||||
(let ((header (read-zip-local-file-header-record stream)))
|
||||
(file-position stream
|
||||
(+ (file-position stream)
|
||||
(zip-local-file-header-record-file-name-length header)
|
||||
(zip-local-file-header-record-extra-field-length header)))
|
||||
(case (zip-entry-compression-method entry)
|
||||
(:stored
|
||||
(loop with bsize = 65536
|
||||
with block = (make-array bsize :element-type '(unsigned-byte 8))
|
||||
for length = (zip-entry-compressed-size entry)
|
||||
then (- length read)
|
||||
for read = (read-sequence block stream :end (min bsize length))
|
||||
until (progn (write-sequence block output :end read)
|
||||
(or (zerop read) (zerop (- length read))))))
|
||||
(:deflated
|
||||
(deflate:inflate-stream stream output))
|
||||
(t
|
||||
(zip-processing-error
|
||||
"Unsupported ZIP compression method: ~A."
|
||||
(zip-entry-compression-method entry))))))
|
||||
|
||||
(defun unzip-zip-entry-to-stream (pathname entry output)
|
||||
(with-open-file (stream pathname :element-type '(unsigned-byte 8))
|
||||
(unzip-zip-entry-from-stream-to-stream stream entry output)))
|
||||
|
||||
(defun sanitized-zip-entry-pathname (entry-filename)
|
||||
(let ((pathname (pathname entry-filename)))
|
||||
(make-pathname
|
||||
:host
|
||||
(when (pathname-host pathname)
|
||||
(zip-processing-warn "Ignoring strange host component in zip entry filename: ~S" pathname)
|
||||
nil)
|
||||
:device
|
||||
(when (pathname-device pathname)
|
||||
(zip-processing-warn "Ignoring strange device component in zip entry filename: ~S" pathname)
|
||||
nil)
|
||||
:directory
|
||||
(let ((directory (pathname-directory pathname)))
|
||||
(when (and (consp directory)
|
||||
(not (eq (first directory) :relative)))
|
||||
(zip-processing-warn "Ignoring non-relative directory in zip entry filename: ~S" pathname)
|
||||
(if (keywordp (first directory))
|
||||
(setf (first directory) :relative)
|
||||
(push :relative directory)))
|
||||
(when (and (consp directory) (member :back directory))
|
||||
(zip-processing-warn "Ignoring :back entries in directory in zip entry filename: ~S" pathname)
|
||||
(setq directory (delete :back directory)))
|
||||
directory)
|
||||
:name (pathname-name pathname)
|
||||
:type (pathname-type pathname)
|
||||
:version
|
||||
(when (pathname-version pathname)
|
||||
(zip-processing-warn "Ignoring strange version component in zip entry filename: ~S" pathname)
|
||||
nil))))
|
||||
|
||||
(defun unzip-zip-archive (pathname directory &key prefix)
|
||||
(let* ((*zip-processing-pathname* (pathname pathname))
|
||||
(archive (read-zip-archive pathname)))
|
||||
(with-open-file (stream pathname :element-type '(unsigned-byte 8))
|
||||
(dolist (entry (zip-archive-entries archive))
|
||||
(let ((entry-filename (zip-entry-file-name entry)))
|
||||
(when prefix
|
||||
(multiple-value-bind (new matchp)
|
||||
(cl-ppcre:regex-replace prefix entry-filename "")
|
||||
(if matchp
|
||||
(setq entry-filename new)
|
||||
(setq entry-filename nil))))
|
||||
(cond
|
||||
((null entry-filename)
|
||||
;; Skip non-matched entries
|
||||
t)
|
||||
((zip-entry-directory-p entry)
|
||||
(ensure-directories-exist
|
||||
(merge-pathnames (make-pathname :name "dummy")
|
||||
(merge-pathnames (sanitized-zip-entry-pathname entry-filename) directory))))
|
||||
(t
|
||||
(let ((destination (merge-pathnames (sanitized-zip-entry-pathname entry-filename) directory)))
|
||||
(ensure-directories-exist destination)
|
||||
(with-open-file (output destination :direction :output
|
||||
:if-exists :supersede
|
||||
:element-type '(unsigned-byte 8))
|
||||
(unzip-zip-entry-from-stream-to-stream stream entry output))))))))))
|
||||
25
setup-common.lisp
Normal file
25
setup-common.lisp
Normal file
@ -0,0 +1,25 @@
|
||||
;;;; OpenScenarioNext --- OpenScenario Language Design
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; setup-common.lisp --- Common setup for building
|
||||
|
||||
(cl:in-package #:cl-user)
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; Setup everything so that ASDF building of the system will work,
|
||||
;;;; regardless of the current working directory or other stuff.
|
||||
;;;;
|
||||
|
||||
;;; Require asdf just in case it is not present.
|
||||
|
||||
(require "ASDF")
|
||||
|
||||
;;; Add current path and tool paths to central-registry
|
||||
|
||||
(let ((base-dir (make-pathname :name nil :type nil :defaults *load-pathname*)))
|
||||
;; The OSN directory itself
|
||||
(push base-dir asdf:*central-registry*)
|
||||
;; All needed and bundled tools
|
||||
(dolist (path '(#p"tools/cl-ppcre/" #p"tools/cl-yacc/"))
|
||||
(push (merge-pathnames path base-dir) asdf:*central-registry*)))
|
||||
143
src/conditions.lisp
Normal file
143
src/conditions.lisp
Normal file
@ -0,0 +1,143 @@
|
||||
;;;; OpenScenarioNext --- OpenScenario Language Design
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; conditions.lisp --- Basic Condition System Definitions
|
||||
|
||||
(cl:in-package #:openscenarionext-utils)
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; This file contains the basic condition system definitions, like
|
||||
;;;; common conditions, and signalling helpers, that are used in all
|
||||
;;;; places of the project.
|
||||
;;;;
|
||||
|
||||
(define-condition osn-condition (condition)
|
||||
((context :initarg :context :initform nil :reader osn-condition-context)))
|
||||
|
||||
(defgeneric osn-condition-short-string (condition))
|
||||
|
||||
(defmethod osn-condition-short-string ((condition osn-condition))
|
||||
"")
|
||||
|
||||
(defmethod osn-condition-short-string ((condition simple-condition))
|
||||
(format nil "~?"
|
||||
(simple-condition-format-control condition)
|
||||
(simple-condition-format-arguments condition)))
|
||||
|
||||
(defmethod print-object :before ((c osn-condition) stream)
|
||||
(unless *print-escape*
|
||||
(format stream "~A~@[ in ~A~]: " (type-of c) (osn-condition-context c))))
|
||||
|
||||
(define-condition osn-warning (osn-condition warning)
|
||||
())
|
||||
|
||||
(define-condition osn-error (osn-condition error)
|
||||
())
|
||||
|
||||
(define-condition osn-user-condition (osn-condition)
|
||||
())
|
||||
|
||||
(define-condition osn-internal-condition (osn-condition)
|
||||
())
|
||||
|
||||
(define-condition osn-unexpected-condition (osn-condition simple-condition)
|
||||
((cause :initarg :cause :reader osn-unexpected-condition-cause))
|
||||
(:report (lambda (c s)
|
||||
(format s "~A: Cause: ~A"
|
||||
(osn-condition-short-string c)
|
||||
(osn-unexpected-condition-cause c)))))
|
||||
|
||||
(define-condition osn-user-warning (osn-user-condition osn-warning)
|
||||
())
|
||||
|
||||
(define-condition osn-internal-warning (osn-internal-condition osn-warning)
|
||||
())
|
||||
|
||||
(define-condition osn-unexpected-warning (osn-unexpected-condition osn-warning)
|
||||
())
|
||||
|
||||
(define-condition osn-user-error (osn-user-condition osn-error)
|
||||
())
|
||||
|
||||
(define-condition osn-internal-error (osn-internal-condition osn-error)
|
||||
())
|
||||
|
||||
(define-condition osn-unexpected-error (osn-unexpected-condition osn-error)
|
||||
())
|
||||
|
||||
(define-condition osn-simple-user-warning
|
||||
(osn-user-warning simple-condition)
|
||||
())
|
||||
|
||||
(define-condition osn-simple-internal-warning
|
||||
(osn-internal-warning simple-condition)
|
||||
())
|
||||
|
||||
(define-condition osn-simple-user-error
|
||||
(osn-user-error simple-condition)
|
||||
())
|
||||
|
||||
(define-condition osn-simple-internal-error
|
||||
(osn-internal-error simple-condition)
|
||||
())
|
||||
|
||||
(defun make-unexpected-error-handler (context format &rest arguments)
|
||||
(lambda (c)
|
||||
(unless (typep c 'osn-condition)
|
||||
(error 'osn-unexpected-error :context context
|
||||
:format-control format :format-arguments arguments :cause c))))
|
||||
|
||||
(defun make-unexpected-warning-handler (context format &rest arguments)
|
||||
(lambda (c)
|
||||
(unless (typep c 'osn-condition)
|
||||
(warn 'osn-unexpected-warning :context context
|
||||
:format-control format :format-arguments arguments :cause c))))
|
||||
|
||||
(define-condition osn-assert-failure (osn-simple-internal-error)
|
||||
((assertion :initarg :assertion :reader osn-assert-failure-assertion)))
|
||||
|
||||
(defmethod print-object ((c osn-assert-failure) stream)
|
||||
(if *print-escape*
|
||||
(call-next-method)
|
||||
(progn
|
||||
(call-next-method)
|
||||
(format stream " [Failed form: ~S]" (osn-assert-failure-assertion c)))))
|
||||
|
||||
(defmacro osn-assert (test-form context &optional control &rest arguments)
|
||||
`(assert ,test-form nil 'osn-assert-failure
|
||||
:context ,context :assertion ',test-form
|
||||
,@(if control
|
||||
(list :format-control control
|
||||
:format-arguments `(list ,@arguments))
|
||||
(list :format-control "Assertion failed"
|
||||
:format-arguments nil))))
|
||||
|
||||
(defun osn-user-warn (context datum &rest arguments)
|
||||
(warn
|
||||
(coerce-to-osn-condition context datum arguments 'osn-simple-user-warning)))
|
||||
|
||||
(defun osn-internal-warn (context datum &rest arguments)
|
||||
(warn
|
||||
(coerce-to-osn-condition context datum arguments
|
||||
'osn-simple-internal-warning)))
|
||||
|
||||
(defun osn-user-error (context datum &rest arguments)
|
||||
(error
|
||||
(coerce-to-osn-condition context datum arguments 'osn-simple-user-error)))
|
||||
|
||||
(defun osn-internal-error (context datum &rest arguments)
|
||||
(error
|
||||
(coerce-to-osn-condition context datum arguments
|
||||
'osn-simple-internal-error)))
|
||||
|
||||
(defun coerce-to-osn-condition (context datum arguments default-type)
|
||||
(etypecase datum
|
||||
(condition datum)
|
||||
((or string function)
|
||||
(make-condition default-type
|
||||
:context context
|
||||
:format-control datum
|
||||
:format-arguments arguments))
|
||||
(symbol
|
||||
(apply #'make-condition datum :context context arguments))))
|
||||
516
src/osn-parser.lisp
Normal file
516
src/osn-parser.lisp
Normal file
@ -0,0 +1,516 @@
|
||||
;;;; OpenScenarioNext --- OpenScenario Language Design
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; osn-parser.lisp --- OpenScenarioNext Parser
|
||||
|
||||
(cl:in-package #:openscenarionext-io)
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; Lexer and Parser for OpenScenarioNext
|
||||
;;;;
|
||||
|
||||
(define-condition osn-file-reader-error (osn-user-error)
|
||||
((source :initarg :source :initform "<UNKNOWN>" :reader osn-file-reader-error-source)
|
||||
(reason :initarg :reason :initform nil :reader osn-file-reader-error-reason)
|
||||
(args :initarg :args :initform nil :reader osn-file-reader-error-args))
|
||||
(:default-initargs :context :osn-io)
|
||||
(:report
|
||||
(lambda (condition stream)
|
||||
(format stream "While reading OSN File ~A: ~A"
|
||||
(osn-file-reader-error-source condition)
|
||||
(osn-condition-short-string condition)))))
|
||||
|
||||
(defmethod osn-condition-short-string ((condition osn-file-reader-error))
|
||||
(format nil "~?"
|
||||
(osn-file-reader-error-reason condition)
|
||||
(osn-file-reader-error-args condition)))
|
||||
|
||||
(define-condition osn-file-lexer-error (osn-file-reader-error)
|
||||
())
|
||||
|
||||
(define-condition osn-file-parser-error (osn-file-reader-error)
|
||||
())
|
||||
|
||||
;;;
|
||||
;;; Reader
|
||||
;;;
|
||||
|
||||
(defun read-osn-file (pathname)
|
||||
(parse-osn-file pathname))
|
||||
|
||||
;;; Lexer
|
||||
|
||||
(defparameter *osn-keywords*
|
||||
'((osn-lang::|Scenario| . scenario)
|
||||
(osn-lang::|Act| . act)
|
||||
(osn-lang::|Prototypes| . prototypes)
|
||||
(osn-lang::|Resources| . resources)
|
||||
(osn-lang::|init| . init)
|
||||
(osn-lang::|start| . start)
|
||||
(osn-lang::|stop| . stop)))
|
||||
|
||||
(defstruct osn-file-lexer-state
|
||||
source
|
||||
stream
|
||||
(state :initial))
|
||||
|
||||
(defun osn-file-lexer-skip-ws (lexer-state)
|
||||
(loop with stream = (osn-file-lexer-state-stream lexer-state)
|
||||
for char = (peek-char nil stream nil nil)
|
||||
while (and char
|
||||
(or (member char '(#\Space #\Tab #\Newline #\Return))
|
||||
(when (char= char #\/)
|
||||
(read-char stream nil nil)
|
||||
(if (eql #\/ (peek-char nil stream nil nil))
|
||||
(prog1 t (osn-file-lexer-skip-to-nl lexer-state))
|
||||
(prog1 nil (unread-char char stream))))))
|
||||
do (read-char stream nil nil)))
|
||||
|
||||
(defun osn-file-lexer-skip-to-nl (lexer-state)
|
||||
(loop with stream = (osn-file-lexer-state-stream lexer-state)
|
||||
for char = (peek-char nil stream nil nil)
|
||||
while (and char (not (member char '(#\Newline #\Return))))
|
||||
do (read-char stream nil nil)))
|
||||
|
||||
(defun osn-file-lexer-skip-nl (lexer-state)
|
||||
(let* ((stream (osn-file-lexer-state-stream lexer-state))
|
||||
(char (read-char stream nil nil)))
|
||||
(case char
|
||||
(#\Return
|
||||
(when (eql (peek-char nil stream nil nil) #\Newline)
|
||||
(read-char stream nil nil)))
|
||||
(#\Newline
|
||||
t)
|
||||
(t
|
||||
(when char
|
||||
(unread-char char stream))))))
|
||||
|
||||
(defun osn-file-lexer (lexer-state)
|
||||
(osn-file-lexer-skip-ws lexer-state)
|
||||
(let* ((stream (osn-file-lexer-state-stream lexer-state))
|
||||
(ch (read-char stream nil nil)))
|
||||
(cond
|
||||
((null ch) (values nil nil))
|
||||
((or (char<= #\A ch #\Z)
|
||||
(char<= #\a ch #\z)
|
||||
(char= ch #\_))
|
||||
(let* ((id (osn-file-lexer-read-identifier lexer-state ch))
|
||||
(entry (assoc id *osn-keywords* :test #'equal)))
|
||||
(if entry
|
||||
(values (cdr entry) id)
|
||||
(values 'identifier id))))
|
||||
((char<= #\0 ch #\9)
|
||||
(values 'number
|
||||
(osn-file-lexer-read-number-literal lexer-state ch)))
|
||||
((char= ch #\")
|
||||
(values 'string
|
||||
(osn-file-lexer-read-string-literal lexer-state)))
|
||||
((char= ch #\:)
|
||||
(values 'colon ch))
|
||||
((char= ch #\@)
|
||||
(values 'at))
|
||||
((char= ch #\%)
|
||||
(values 'percent))
|
||||
((char= ch #\()
|
||||
(values 'open))
|
||||
((char= ch #\))
|
||||
(values 'close))
|
||||
((char= ch #\,)
|
||||
(values 'comma))
|
||||
((char= ch #\=)
|
||||
(case (peek-char nil stream nil nil)
|
||||
(#\= (read-char stream nil nil)
|
||||
(values 'relation-op '=))
|
||||
(t (values 'assign))))
|
||||
((char= ch #\!)
|
||||
(case (peek-char nil stream nil nil)
|
||||
(#\= (read-char stream nil nil)
|
||||
(values 'relation-op '/=))
|
||||
(t (values 'not))))
|
||||
((char= ch #\|)
|
||||
(values 'line))
|
||||
((char= ch #\.)
|
||||
(values 'dot))
|
||||
((char= ch #\+)
|
||||
(values 'plus '+))
|
||||
((char= ch #\-)
|
||||
(values 'minus '-))
|
||||
((char= ch #\*)
|
||||
(values 'times '*))
|
||||
((char= ch #\/)
|
||||
(values 'divide '/))
|
||||
((char= ch #\<)
|
||||
(case (peek-char nil stream nil nil)
|
||||
(#\= (read-char stream nil nil)
|
||||
(values 'relation-op '<=))
|
||||
(t (values 'relation-op '<))))
|
||||
((char= ch #\>)
|
||||
(case (peek-char nil stream nil nil)
|
||||
(#\= (read-char stream nil nil)
|
||||
(values 'relation-op '>=))
|
||||
(t (values 'relation-op '>))))
|
||||
(t
|
||||
(error "Unexpected character \"~A\"" ch)))))
|
||||
|
||||
(defun osn-file-lexer-read-string-literal (lexer-state)
|
||||
(loop with stream = (osn-file-lexer-state-stream lexer-state)
|
||||
with result = (make-array 20 :element-type 'lw:simple-char
|
||||
:adjustable t :fill-pointer 0)
|
||||
for char = (read-char stream nil nil)
|
||||
while (and char (char/= char #\"))
|
||||
do
|
||||
(when (char= char #\\)
|
||||
(setq char (read-char stream nil nil))
|
||||
(when (null char)
|
||||
(loop-finish)))
|
||||
(vector-push-extend char result)
|
||||
finally
|
||||
(return (coerce result 'simple-string))))
|
||||
|
||||
(defun osn-file-lexer-read-identifier (lexer-state first-char)
|
||||
(loop with stream = (osn-file-lexer-state-stream lexer-state)
|
||||
with result = (make-array 20 :element-type 'lw:simple-char
|
||||
:adjustable t :fill-pointer 0)
|
||||
initially (vector-push-extend first-char result)
|
||||
for char = (read-char stream nil nil)
|
||||
while (and char
|
||||
(or (char<= #\A char #\Z)
|
||||
(char<= #\a char #\z)
|
||||
(char<= #\0 char #\9)
|
||||
(char= char #\_)))
|
||||
do
|
||||
(vector-push-extend char result)
|
||||
finally
|
||||
(when char (unread-char char stream))
|
||||
(return (intern (coerce result 'simple-string)
|
||||
(find-package '#:osn-lang)))))
|
||||
|
||||
(defun osn-file-lexer-read-number-literal (lexer-state first-char)
|
||||
(loop with stream = (osn-file-lexer-state-stream lexer-state)
|
||||
with result = (make-array 20 :element-type 'lw:simple-char
|
||||
:adjustable t :fill-pointer 0)
|
||||
with state = (if (char= first-char #\-) :start :integer)
|
||||
initially (vector-push-extend first-char result)
|
||||
for char = (read-char stream nil nil)
|
||||
while char
|
||||
do
|
||||
(ecase state
|
||||
(:start
|
||||
(case char
|
||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
(vector-push-extend char result)
|
||||
(setq state :integer))
|
||||
(t
|
||||
(error 'osn-file-lexer-error :source (osn-file-lexer-state-source lexer-state)
|
||||
:reason "Missing digit in numeric literal: Expected digit, got ~A."
|
||||
:args (list (or char "<EOF>"))))))
|
||||
(:integer
|
||||
(case char
|
||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
(vector-push-extend char result))
|
||||
(#\.
|
||||
(vector-push-extend char result)
|
||||
(setq state :real))
|
||||
(t
|
||||
(loop-finish))))
|
||||
(:real
|
||||
(case char
|
||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
(vector-push-extend char result))
|
||||
((#\E #\e)
|
||||
(vector-push-extend #\d result)
|
||||
(setq state :exponent-sign))
|
||||
(t
|
||||
(loop-finish))))
|
||||
(:exponent-sign
|
||||
(case char
|
||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
(vector-push-extend char result)
|
||||
(setq state :exponent))
|
||||
(#\-
|
||||
(vector-push-extend #\- result)
|
||||
(setq state :exponent-digit))
|
||||
(#\+
|
||||
(setq state :exponent-digit))
|
||||
(t
|
||||
;; This is an error
|
||||
(loop-finish))))
|
||||
(:exponent-digit
|
||||
(case char
|
||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
(vector-push-extend char result)
|
||||
(setq state :exponent))
|
||||
(t
|
||||
;; This is an error
|
||||
(loop-finish))))
|
||||
(:exponent
|
||||
(case char
|
||||
((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
(vector-push-extend char result))
|
||||
(t
|
||||
(loop-finish)))))
|
||||
finally
|
||||
(when char
|
||||
(unread-char char stream))
|
||||
(ecase state
|
||||
(:integer (return (parse-integer result)))
|
||||
((:real :exponent) (return (coerce (let ((*read-default-float-format* 'double-float)) (read-from-string result)) 'double-float)))
|
||||
((:exponent-sign :exponent-digit)
|
||||
(error 'osn-file-lexer-error :source (osn-file-lexer-state-source lexer-state)
|
||||
:reason "Missing digit in exponent of real-literal: Expected digit, got ~A."
|
||||
:args (list (or char "<EOF>")))))))
|
||||
|
||||
#|
|
||||
(defun osn-file-lexer (lexer-state)
|
||||
(loop
|
||||
(ecase (osn-file-lexer-state-state lexer-state)
|
||||
((:initial)
|
||||
(if (eql (peek-char nil (osn-file-lexer-state-stream lexer-state) nil nil) #\/)
|
||||
;; Maybe comment
|
||||
(let ((next-char (progn (read-char (osn-file-lexer-state-stream lexer-state) nil nil)
|
||||
(peek-char nil (osn-file-lexer-state-stream lexer-state) nil nil))))
|
||||
(cond
|
||||
((eql next-char #\/)
|
||||
(osn-file-lexer-skip-to-nl lexer-state)
|
||||
(setf (osn-file-lexer-state-state lexer-state) :initial))
|
||||
(t
|
||||
(setf (osn-file-lexer-state-state lexer-state) :foo))))
|
||||
(osn-file-lexer-skip-ws lexer-state)
|
||||
(let ((next-char (read-char (osn-file-lexer-state-stream lexer-state) nil nil)))
|
||||
(case next-char
|
||||
((nil) (return (values nil nil)))
|
||||
(#\/
|
||||
(osn-file-lexer-skip-to-nl lexer-state))
|
||||
((#\Newline #\Return) (osn-file-lexer-skip-nl lexer-state) (return (values :newline nil)))
|
||||
(#\= (return (values :assignment nil)))
|
||||
(#\" (return (osn-file-lexer-read-string-literal lexer-state)))
|
||||
((#\- #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)
|
||||
(let ((result (osn-file-lexer-read-number-literal-maybe lexer-state next-char)))
|
||||
(etypecase result
|
||||
(string (return (values :identifier result)))
|
||||
(integer (return (values :integer-literal result)))
|
||||
(double-float (return (values :real-literal result))))))
|
||||
(t
|
||||
(let ((result (osn-file-lexer-read-identifier-maybe lexer-state next-char)))
|
||||
(etypecase result
|
||||
(string (return (values 'id result)))
|
||||
(boolean (return (values :boolean-literal result)))
|
||||
(symbol (return (values result result))))))))))))
|
||||
|#
|
||||
;;; Parser
|
||||
|
||||
(yacc:define-parser *osn-file-parser*
|
||||
(:start-symbol osn-file)
|
||||
(:terminals (scenario act rule identifier colon at percent
|
||||
init start stop open close comma assign
|
||||
relation-op
|
||||
plus minus times divide
|
||||
number string line dot))
|
||||
(:precedence ((:left comma) (:left line) (:left assign)
|
||||
(:left times divide) (:left plus minus)))
|
||||
(:print-goto-graph t)
|
||||
(:print-states t)
|
||||
(:print-first-terminals t)
|
||||
(:print-lookaheads t)
|
||||
|
||||
(osn-file
|
||||
scenario-expr)
|
||||
|
||||
(scenario-expr
|
||||
(scenario identifier colon act-list
|
||||
(lambda (scn name col acts)
|
||||
(make-scenario :name name :acts acts))))
|
||||
(act-list
|
||||
(act-expr act-list #'cons)
|
||||
(act-expr))
|
||||
(act-expr
|
||||
(act identifier colon rule-list
|
||||
(lambda (act name col rules)
|
||||
(make-act :name name :rules rules))))
|
||||
(rule-list
|
||||
(rule-expr rule-list #'cons)
|
||||
(rule-expr))
|
||||
(rule-expr
|
||||
(at condition colon action-list
|
||||
(lambda (at condition col actions)
|
||||
(make-rule :condition condition
|
||||
:actions actions)))
|
||||
(at condition modifier colon action-list
|
||||
(lambda (at condition modifier col actions)
|
||||
(make-rule :condition condition
|
||||
:modifier modifier
|
||||
:actions actions))))
|
||||
(modifier
|
||||
(percent identifier
|
||||
#'(lambda (pct id) id)))
|
||||
(condition
|
||||
predicate
|
||||
relation-expr
|
||||
binary-expr)
|
||||
(predicate
|
||||
atomic-predicate
|
||||
function-application)
|
||||
(atomic-predicate
|
||||
init start stop)
|
||||
(relation-expr
|
||||
(scalar-expr relation-op scalar-expr
|
||||
#'(lambda (a op b)
|
||||
`(,op ,a ,b))))
|
||||
(binary-expr
|
||||
(condition and condition)
|
||||
(condition or condition))
|
||||
(action-list
|
||||
(action-expr action-list #'cons)
|
||||
(action-expr))
|
||||
(action-expr
|
||||
function-application)
|
||||
(function-application
|
||||
(identifier open close
|
||||
#'(lambda (name open close)
|
||||
(declare (ignore open close))
|
||||
(list name)))
|
||||
(identifier open arguments-list close
|
||||
#'(lambda (name open args close)
|
||||
(list* name args))))
|
||||
(arguments-list
|
||||
(argument comma arguments-list
|
||||
#'(lambda (arg comma rest)
|
||||
(cons arg rest)))
|
||||
(argument))
|
||||
(argument
|
||||
named-arg
|
||||
arg-expr)
|
||||
(named-arg
|
||||
(identifier assign arg-expr
|
||||
#'(lambda (name assign arg)
|
||||
(cons name arg))))
|
||||
(arg-expr
|
||||
scalar-expr
|
||||
coordinate-expr)
|
||||
(scalar-expr
|
||||
identifier
|
||||
record-expr
|
||||
literal
|
||||
function-application
|
||||
arithmetic-expr)
|
||||
(record-expr
|
||||
(identifier dot identifier
|
||||
#'(lambda (a dot b)
|
||||
`(-> ,a ,b))))
|
||||
(arithmetic-expr
|
||||
product-expr
|
||||
sum-expr)
|
||||
(product-expr
|
||||
(scalar-expr times scalar-expr
|
||||
#'(lambda (a times b)
|
||||
`(* ,a ,b)))
|
||||
(scalar-expr divide scalar-expr
|
||||
#'(lambda (a divide b)
|
||||
`(/ ,a ,b))))
|
||||
(sum-expr
|
||||
(scalar-expr plus scalar-expr
|
||||
#'(lambda (a plus b)
|
||||
`(+ ,a ,b)))
|
||||
(scalar-expr minus scalar-expr
|
||||
#'(lambda (a minus b)
|
||||
`(- ,a ,b))))
|
||||
(coordinate-expr
|
||||
(coordinate-list
|
||||
#'(lambda (list) (make-tuple :items list))))
|
||||
(coordinate-list
|
||||
(scalar-expr coordinate-rest #'cons))
|
||||
(coordinate-rest
|
||||
(line scalar-expr coordinate-rest
|
||||
#'(lambda (line arg rest) (cons arg rest)))
|
||||
(line scalar-expr
|
||||
#'(lambda (line arg) (list arg))))
|
||||
(literal
|
||||
number
|
||||
(minus number
|
||||
#'(lambda (minus number)
|
||||
(- number)))
|
||||
(plus number
|
||||
#'(lambda (plus number)
|
||||
number))
|
||||
string))
|
||||
|
||||
(defun parse-osn-file (path)
|
||||
(with-open-file (stream path)
|
||||
(parse-osn-stream stream :source path)))
|
||||
|
||||
(defun parse-osn-stream (stream &key source)
|
||||
(let ((lexer-state (make-osn-file-lexer-state :stream stream
|
||||
:source source)))
|
||||
(labels ((lexer ()
|
||||
(osn-file-lexer lexer-state)))
|
||||
(yacc:parse-with-lexer #'lexer *osn-file-parser*))))
|
||||
|
||||
#|
|
||||
|
||||
|
||||
(defun osn-file-parser (lexer-state)
|
||||
(multiple-value-bind (next-token next-value) (osn-file-lexer lexer-state)
|
||||
(labels ((next-p (token-or-set)
|
||||
(if (consp token-or-set)
|
||||
(member next-token token-or-set)
|
||||
(eql next-token token-or-set)))
|
||||
(parse (&rest expected-tokens)
|
||||
(loop with result-value = nil
|
||||
with result-token = nil
|
||||
for expected in expected-tokens
|
||||
if (next-p expected)
|
||||
do
|
||||
(setq result-value next-value result-token next-token)
|
||||
(multiple-value-setq (next-token next-value) (osn-file-lexer lexer-state))
|
||||
else
|
||||
do
|
||||
(error 'osn-file-reader-error :source (osn-file-lexer-state-source lexer-state)
|
||||
:reason "Expecting ~:[~A~;one of ~{~A~^, ~}~] but got ~:[EOF~;~:*~A~]!"
|
||||
:args (list (consp expected) expected next-token))
|
||||
finally (return (values result-value result-token))))
|
||||
(preamble ()
|
||||
(list :version (prog1 (version) (parse :newline)) :meta-entries (meta-entries)))
|
||||
(version ()
|
||||
(parse :meta-comment :file-version :assignment :string-literal))
|
||||
(meta-entries ()
|
||||
(when (next-p :meta-comment)
|
||||
(cons (prog1 (meta-entry) (parse :newline)) (meta-entries))))
|
||||
(meta-entry ()
|
||||
(parse :meta-comment)
|
||||
(entry))
|
||||
(content ()
|
||||
(unless (next-p nil)
|
||||
(nconc
|
||||
(line)
|
||||
(content))))
|
||||
(line ()
|
||||
(if (next-p :newline)
|
||||
(parse :newline)
|
||||
(prog1 (list (entry t)) (parse :newline))))
|
||||
(entry (&optional multi-line-p)
|
||||
(let ((name (name)))
|
||||
(multiple-value-bind (value kind)
|
||||
(parse :assignment
|
||||
(if multi-line-p '(:boolean-literal :integer-literal :real-literal :string-literal :multi-line-string-literal)
|
||||
'(:boolean-literal :integer-literal :real-literal :string-literal)))
|
||||
(list (ecase kind
|
||||
(:boolean-literal 'osn-entry-boolean)
|
||||
(:integer-literal 'osn-entry-integer)
|
||||
(:real-literal 'osn-entry-real)
|
||||
((:string-literal :multi-line-string-literal) 'osn-entry-string))
|
||||
:name name :value value))))
|
||||
(name ()
|
||||
(parse '(:identifier :string-literal))))
|
||||
(nconc (preamble) (list :data-entries (content))))))
|
||||
|
||||
(defun parse-osn-file (pathname)
|
||||
(with-open-file (stream pathname :element-type 'lw:simple-char :external-format :utf-8)
|
||||
(parse-osn-file-from-stream stream pathname)))
|
||||
|
||||
(defun parse-osn-file-from-stream (stream &optional source)
|
||||
(let ((lexer-state (make-osn-file-lexer-state :source source :stream stream)))
|
||||
(list :osn
|
||||
(osn-file-parser lexer-state))))
|
||||
|
||||
|#
|
||||
65
src/osn-writer.lisp
Normal file
65
src/osn-writer.lisp
Normal file
@ -0,0 +1,65 @@
|
||||
;;;; OpenScenarioNext --- OpenScenario Language Design
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; osn-writer.lisp --- OpenScenarioNext Writer
|
||||
|
||||
(cl:in-package #:openscenarionext-io)
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; Writer for OpenScenarioNext
|
||||
;;;;
|
||||
|
||||
(defun write-osn-file (osn pathname)
|
||||
(with-open-file (stream pathname :direction :output)
|
||||
(write-osn-stream osn stream)))
|
||||
|
||||
(defun write-osn-stream (osn stream)
|
||||
(format stream "~&Scenario ~A:~2%" (scenario-name osn))
|
||||
(dolist (act (scenario-acts osn))
|
||||
(format stream "~& Act ~A:~2%" (act-name act))
|
||||
(dolist (rule (act-rules act))
|
||||
(format stream "~& @~A~@[ % ~A~]:~%~{ ~A~%~}~%"
|
||||
(generate-osn-expression (rule-condition rule))
|
||||
(rule-modifier rule)
|
||||
(mapcar #'generate-osn-expression
|
||||
(rule-actions rule))))))
|
||||
|
||||
(defmethod generate-osn-expression ((expr cons))
|
||||
(case (car expr)
|
||||
(->
|
||||
(concatenate 'string (generate-osn-expression (cadr expr))
|
||||
"."
|
||||
(generate-osn-expression (caddr expr))))
|
||||
((+ - * /)
|
||||
(concatenate 'string (generate-osn-expression (cadr expr))
|
||||
(symbol-name (car expr))
|
||||
(generate-osn-expression (caddr expr))))
|
||||
((< <= > >= == /=)
|
||||
(concatenate 'string (generate-osn-expression (cadr expr))
|
||||
(ecase (car expr)
|
||||
(< "<")
|
||||
(<= "<=")
|
||||
(> ">")
|
||||
(>= ">=")
|
||||
(== "==")
|
||||
(/= "!="))
|
||||
(generate-osn-expression (caddr expr))))
|
||||
(t
|
||||
(if (listp (cdr expr))
|
||||
(format nil "~A(~{~A~^,~})"
|
||||
(car expr)
|
||||
(mapcar #'generate-osn-expression (cdr expr)))
|
||||
(format nil "~A=~A"
|
||||
(car expr)
|
||||
(generate-osn-expression (cdr expr)))))))
|
||||
|
||||
(defmethod generate-osn-expression ((expr symbol))
|
||||
(symbol-name expr))
|
||||
|
||||
(defmethod generate-osn-expression ((expr tuple))
|
||||
(format nil "~{~A~^|~}"
|
||||
(mapcar #'generate-osn-expression (tuple-items expr))))
|
||||
|
||||
(defmethod generate-osn-expression ((expr number))
|
||||
(format nil "~A" expr))
|
||||
32
src/osn.lisp
Normal file
32
src/osn.lisp
Normal file
@ -0,0 +1,32 @@
|
||||
;;;; OpenScenarioNext --- OpenScenario Language Design
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; osn.lisp --- OpenScenarioNext AST
|
||||
|
||||
(cl:in-package #:openscenarionext-io)
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; AST for OpenScenarioNext
|
||||
;;;;
|
||||
|
||||
(defstruct osn-file
|
||||
scenario)
|
||||
|
||||
(defstruct scenario
|
||||
name
|
||||
acts
|
||||
prototypes
|
||||
resources)
|
||||
|
||||
(defstruct act
|
||||
name
|
||||
rules)
|
||||
|
||||
(defstruct rule
|
||||
condition
|
||||
modifier
|
||||
actions)
|
||||
|
||||
(defstruct tuple
|
||||
items)
|
||||
80
src/pkgdef.lisp
Normal file
80
src/pkgdef.lisp
Normal file
@ -0,0 +1,80 @@
|
||||
;;;; OpenScenarioNext --- OpenScenario Language Design
|
||||
;;;; This is copyrighted software. See documentation for terms.
|
||||
;;;;
|
||||
;;;; pkgdef.lisp --- Package Definitions
|
||||
|
||||
(cl:in-package #:cl-user)
|
||||
|
||||
;;;; %File Description:
|
||||
;;;;
|
||||
;;;; Define all OSN-related packages.
|
||||
;;;;
|
||||
|
||||
(defpackage #:openscenarionext-utils
|
||||
(:nicknames #:osn-utils)
|
||||
(:use #:common-lisp)
|
||||
(:export
|
||||
;; conditions.lisp
|
||||
#:osn-condition
|
||||
#:osn-condition-context
|
||||
#:osn-condition-short-string
|
||||
#:osn-warning
|
||||
#:osn-error
|
||||
#:osn-user-condition
|
||||
#:osn-internal-condition
|
||||
#:osn-unexpected-condition
|
||||
#:osn-user-warning
|
||||
#:osn-internal-warning
|
||||
#:osn-unexpected-warning
|
||||
#:osn-user-error
|
||||
#:osn-internal-error
|
||||
#:osn-unexpected-error
|
||||
#:osn-simple-user-warning
|
||||
#:osn-simple-internal-warning
|
||||
#:osn-simple-user-error
|
||||
#:osn-simple-internal-error
|
||||
#:make-unexpected-error-handler
|
||||
#:make-unexpected-warning-handler
|
||||
#:osn-assert-failure
|
||||
#:osn-assert-failure-assertion
|
||||
#:osn-assert
|
||||
#:osn-user-warn
|
||||
#:osn-internal-warn
|
||||
#:coerce-to-osn-condition))
|
||||
|
||||
(defpackage #:openscenarionext
|
||||
(:nicknames #:osn)
|
||||
(:use #:common-lisp #:openscenarionext-utils)
|
||||
(:export
|
||||
#:osn-file
|
||||
#:osn-file-scenario
|
||||
#:scenario
|
||||
#:scenario-name
|
||||
#:scenario-acts
|
||||
#:scenario-prototypes
|
||||
#:scenario-resources
|
||||
#:act
|
||||
#:act-name
|
||||
#:act-rules
|
||||
#:rule
|
||||
#:rule-condition
|
||||
#:rule-modifier
|
||||
#:rule-actions
|
||||
#:tuple
|
||||
#:tuple-items
|
||||
#:make-tuple))
|
||||
|
||||
(defpackage #:openscenarionext-language
|
||||
(:nicknames #:osn-lang)
|
||||
(:use))
|
||||
|
||||
(defpackage #:openscenarionext-io
|
||||
(:nicknames #:osn-io)
|
||||
(:use #:common-lisp
|
||||
#:openscenarionext-utils
|
||||
#:openscenarionext)
|
||||
(:export
|
||||
#:parse-osn-file
|
||||
#:parse-osn-stream
|
||||
#:write-osn-file
|
||||
#:write-osn-stream))
|
||||
1
tools/cl-ppcre
Submodule
1
tools/cl-ppcre
Submodule
Submodule tools/cl-ppcre added at 91bbdc276e
1
tools/cl-yacc
Submodule
1
tools/cl-yacc
Submodule
Submodule tools/cl-yacc added at 1334f54692
Reference in New Issue
Block a user