commit 8126f8e3d1f337f25ff222a1176aabf8d65e6233 Author: Pierre R. Mai Date: Wed Aug 7 16:16:36 2019 +0200 Initial CL parser/generator implementation diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..fa89f01 --- /dev/null +++ b/.gitmodules @@ -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 diff --git a/OSN.asd b/OSN.asd new file mode 100644 index 0000000..4eb909a --- /dev/null +++ b/OSN.asd @@ -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 " + :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")) diff --git a/lib/COPYING b/lib/COPYING new file mode 100644 index 0000000..61e4936 --- /dev/null +++ b/lib/COPYING @@ -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. diff --git a/lib/README b/lib/README new file mode 100644 index 0000000..a360d32 --- /dev/null +++ b/lib/README @@ -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. diff --git a/lib/aes-utilities.lisp b/lib/aes-utilities.lisp new file mode 100644 index 0000000..0793806 --- /dev/null +++ b/lib/aes-utilities.lisp @@ -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)))))) diff --git a/lib/cmdline-utilities.lisp b/lib/cmdline-utilities.lisp new file mode 100644 index 0000000..70ec7d3 --- /dev/null +++ b/lib/cmdline-utilities.lisp @@ -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)) diff --git a/lib/common-utilities.lisp b/lib/common-utilities.lisp new file mode 100644 index 0000000..2c17e73 --- /dev/null +++ b/lib/common-utilities.lisp @@ -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)))))) diff --git a/lib/doc.lisp b/lib/doc.lisp new file mode 100644 index 0000000..97be830 --- /dev/null +++ b/lib/doc.lisp @@ -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)) diff --git a/lib/float-utilities.lisp b/lib/float-utilities.lisp new file mode 100644 index 0000000..d2d9b53 --- /dev/null +++ b/lib/float-utilities.lisp @@ -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)) diff --git a/lib/macro-utilities.lisp b/lib/macro-utilities.lisp new file mode 100644 index 0000000..e5bb30f --- /dev/null +++ b/lib/macro-utilities.lisp @@ -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.")) diff --git a/lib/parsing-utilities.lisp b/lib/parsing-utilities.lisp new file mode 100644 index 0000000..e2d95c0 --- /dev/null +++ b/lib/parsing-utilities.lisp @@ -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 "")))) diff --git a/lib/pecoff-utilities.lisp b/lib/pecoff-utilities.lisp new file mode 100644 index 0000000..bd2d447 --- /dev/null +++ b/lib/pecoff-utilities.lisp @@ -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))) diff --git a/lib/pipe-stream.lisp b/lib/pipe-stream.lisp new file mode 100644 index 0000000..dbba4d8 --- /dev/null +++ b/lib/pipe-stream.lisp @@ -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)))) diff --git a/lib/pkgdef.lisp b/lib/pkgdef.lisp new file mode 100644 index 0000000..edc69db --- /dev/null +++ b/lib/pkgdef.lisp @@ -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)) diff --git a/lib/printf.lisp b/lib/printf.lisp new file mode 100644 index 0000000..df75f60 --- /dev/null +++ b/lib/printf.lisp @@ -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)) diff --git a/lib/time-utilities.lisp b/lib/time-utilities.lisp new file mode 100644 index 0000000..53bc1ae --- /dev/null +++ b/lib/time-utilities.lisp @@ -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) diff --git a/lib/zip-utilities.lisp b/lib/zip-utilities.lisp new file mode 100644 index 0000000..06e4126 --- /dev/null +++ b/lib/zip-utilities.lisp @@ -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)))))))))) diff --git a/setup-common.lisp b/setup-common.lisp new file mode 100644 index 0000000..fb3e7e9 --- /dev/null +++ b/setup-common.lisp @@ -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*))) diff --git a/src/conditions.lisp b/src/conditions.lisp new file mode 100644 index 0000000..3a4ba11 --- /dev/null +++ b/src/conditions.lisp @@ -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)))) diff --git a/src/osn-parser.lisp b/src/osn-parser.lisp new file mode 100644 index 0000000..d62ffee --- /dev/null +++ b/src/osn-parser.lisp @@ -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 "" :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 "")))))) + (: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 ""))))))) + +#| +(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)))) + +|# diff --git a/src/osn-writer.lisp b/src/osn-writer.lisp new file mode 100644 index 0000000..029bf58 --- /dev/null +++ b/src/osn-writer.lisp @@ -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)) diff --git a/src/osn.lisp b/src/osn.lisp new file mode 100644 index 0000000..6ba4114 --- /dev/null +++ b/src/osn.lisp @@ -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) diff --git a/src/pkgdef.lisp b/src/pkgdef.lisp new file mode 100644 index 0000000..fc585ca --- /dev/null +++ b/src/pkgdef.lisp @@ -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)) diff --git a/tools/cl-ppcre b/tools/cl-ppcre new file mode 160000 index 0000000..91bbdc2 --- /dev/null +++ b/tools/cl-ppcre @@ -0,0 +1 @@ +Subproject commit 91bbdc276eb31051db87f70223ad6c2751a99efc diff --git a/tools/cl-yacc b/tools/cl-yacc new file mode 160000 index 0000000..1334f54 --- /dev/null +++ b/tools/cl-yacc @@ -0,0 +1 @@ +Subproject commit 1334f5469251ffb3f8738a682dc8ee646cb26635