From cf5e76a2fc7f39204b775804f59a0ff50eff0ce6 Mon Sep 17 00:00:00 2001 From: y5nw Date: Wed, 25 Aug 2021 14:35:27 +0200 Subject: [PATCH] ildb: skip route locks and signal names --- interlocking.lisp | 60 +++++++++++------------------------------------ 1 file changed, 14 insertions(+), 46 deletions(-) diff --git a/interlocking.lisp b/interlocking.lisp index 8b700cd..6fc1565 100644 --- a/interlocking.lisp +++ b/interlocking.lisp @@ -4,7 +4,6 @@ (:export :load-ildb :ars-rule :ars-rule-p :ars-rule-type :ars-rule-match :ars-rule-invertp :tcbside :make-tcbside :tcbside-p :tcbside-pos :tcbside-side - :path-entry :path-entry-p :path-entry-next :path-entry-locks :route :route-p :route-name :route-ars-rules :route-path :tcbdata :tcbdata-p :tcbdata-signal-pos :tcbdata-signal-name :tcbdata-routes :tcb :tcb-p :tcb-pos :tcb-side-a :tcb-side-b @@ -47,30 +46,10 @@ (with-accessors ((p tcbside-pos) (side tcbside-side)) obj (json:encode-json (list (cons "p" p) (cons "s" side))))) -(defstruct path-entry - (next nil :type (or null tcbside)) - (locks (aux:adj-vector-of '(cons aux:v3d string)) :type (vector (cons aux:v3d string)))) - -(defmethod print-object ((obj path-entry) s) - (with-accessors ((next path-entry-next) (locks path-entry-locks)) obj - (print-unreadable-object (obj s) - (format s "TO ~a" (or next "EOI")) - (loop for (pos . st) across locks do - (format s " ~_LOCKING ~a TO ~s" pos st))))) - -(defmethod json:encode-json ((obj path-entry) &optional json:*json-output*) - (with-accessors ((next path-entry-next) (locks path-entry-locks)) obj - (json:encode-json-alist (list (cons "next" next) - (cons "locks" (loop with ht = (make-hash-table) - for i across locks - for (pos . st) = i - do (setf (gethash pos ht) st) - finally (return ht))))))) - (defstruct route (name "" :type string) (ars-rules (aux:adj-vector-of 'ars-rule) :type (or (eql t) (vector ars-rule))) - (path (aux:adj-vector-of 'path-entry) :type (vector path-entry))) + (path (aux:adj-vector-of '(or tcbside null)) :type (vector (or tcbside null)))) (defmethod print-object ((obj route) s) (with-accessors ((name route-name) (ars route-ars-rules) (path route-path)) obj @@ -92,27 +71,20 @@ (defstruct tcbdata (ts nil :type (or string null)) (signal-pos nil :type (or aux:v3d null)) - (signal-name nil :type (or string null)) (routes (aux:adj-vector-of 'route) :type (vector route))) (defmethod print-object ((obj tcbdata) s) - (with-accessors ((ts tcbdata-ts) (spos tcbdata-signal-pos) (sname tcbdata-signal-name) - (routelist tcbdata-routes)) - obj + (with-accessors ((ts tcbdata-ts) (spos tcbdata-signal-pos) (routelist tcbdata-routes)) obj (print-unreadable-object (obj s) - (format s "~:i~:[EOI~;~:*IN SECTION ~a~]~:[~*~; ~:_~:*SIGNALING AT ~a NAMED ~s~]" - ts spos sname) + (format s "~:i~:[EOI~;~:*IN SECTION ~a~]~@[ SIGNALING AT ~a~]" ts spos) (when (> (length routelist) 0) (pprint-indent :block 1 s) (loop for i across routelist do (format s " ~_~a" i)))))) (defmethod json:encode-json ((obj tcbdata) &optional json:*json-output*) - (with-accessors ((ts tcbdata-ts) (spos tcbdata-signal-pos) (sname tcbdata-signal-name) - (routelist tcbdata-routes)) - obj + (with-accessors ((ts tcbdata-ts) (spos tcbdata-signal-pos) (routelist tcbdata-routes)) obj (json:encode-json (list (cons "in_section" ts) (cons "signal_pos" spos) - (cons "signal_name" sname) (cons "routes" routelist))))) (defstruct tcb @@ -173,11 +145,11 @@ finally (return ,r))))) (defmacro route-next (route) - (alexandria:with-gensyms (p) + (alexandria:with-gensyms (p l) (alexandria:once-only (route) - `(let ((,p (route-path ,route))) - (path-entry-next (aref ,p (1- (length ,p)))))))) + `(let* ((,p (route-path ,route)) (,l (length ,p))) + (if (> ,l 0) (aref ,p (1- ,l))))))) (defmacro find-tcb-at (ildb pos) `(gethash ,pos (ildb-tcbs ,ildb))) @@ -194,14 +166,12 @@ finally (return ,locks)))) (defmacro parse-path (pathht) - (alexandria:with-gensyms (ent next p s locks) - `(aux:collect-integrally-indexed-non-nil - ((vector path-entry) ,pathht nil ,ent 1) - (aux:with-entries-in-hash-table (,ent (,next "next") (,locks "locks")) - (aux:with-entries-in-hash-table (,next (,p "p") (,s "s")) - (make-path-entry :next (make-tcbside :pos (aux:hash-table-to-v3d ,p) - :side (1- ,s)) - :locks (parse-route-locks ,locks))))))) + (alexandria:with-gensyms (ent next p s) + `(aux:collect-integrally-indexed-entries + ((vector (or tcbside null)) ,pathht nil ,ent 1) + (let ((,next (gethash "next" ,ent))) + (if ,next (aux:with-entries-in-hash-table (,next (,p "p") (,s "s")) + (make-tcbside :pos (aux:hash-table-to-v3d ,p) :side (1- ,s)))))))) (defmacro parse-ars-rules (rulesht) (alexandria:with-gensyms (ent neg ln rc ftype match) @@ -233,16 +203,14 @@ (parse-route ,ent)))) (defmacro read-tcb-side (side) - (alexandria:with-gensyms (ts spos sname routes) + (alexandria:with-gensyms (ts spos routes) (alexandria:once-only (side) `(let ((,ts (gethash "ts_id" ,side nil)) (,spos (ignore-errors (aux:hash-table-to-v3d (gethash "signal" ,side)))) - (,sname (gethash "signal_name" ,side)) (,routes (read-routes (gethash "routes" ,side (make-hash-table))))) (make-tcbdata :ts ,ts :signal-pos ,spos - :signal-name ,sname :routes ,routes))))) (defun load-ildb (fn)