Changeset 254

Timestamp:

08/18/11 08:09:13 (21 months ago)

Author:

rjs

Message:

Update.

Location:

trunk/lisp/lmio1

Files:

• cdrive.lisp (modified) (1 diff)
• chatst.lisp (modified) (1 diff)
• dplt.lisp (modified) (2 diffs)
• press.lisp (modified) (1 diff)
• rfontw.lisp (modified) (8 diffs)
• time.lisp (modified) (3 diffs)
• xgp.lisp (modified) (1 diff)

trunk/lisp/lmio1/cdrive.lisp

@@ -665 +665 @@
                     (CALIBRATE-AT-LOC (1+ C) (FORMAT NIL "~DA1-10" (1+ C)) CALIBRATOR)
                     (CALIBRATE-AT-LOC (1+ C) (FORMAT NIL "~DF1-10" (1+ C)) CALIBRATOR))
-                  (CALIBRATE-AT-LOC NBOARDS (FORMAT NIL "~DA30-10" NBOARDS) CALIBRATOR)
+                  (CALIBRATE-AT-LOC NBOARDS (FORMAT NIL "~DA29-10" NBOARDS) CALIBRATOR)
                   (CALIBRATE-AT-LOC NBOARDS (FORMAT NIL "~DF25-10" NBOARDS) CALIBRATOR))
                  (LG684

trunk/lisp/lmio1/chatst.lisp

@@ -177 +177 @@
   (SETQ CSR (%UNIBUS-READ CONTROL-STATUS-REGISTER-TEST))
   (SETQ ME (%UNIBUS-READ MY-NUMBER-REGISTER-TEST))
-  (IF (NOT (ZEROP (LDB-TEST %%CHAOS-CSR-TRANSMIT-ABORT CSR)))
+  (IF (LDB-TEST %%CHAOS-CSR-TRANSMIT-ABORT CSR)
       (FORMAT t "~%Transmit aborted, then~%"))
   (COND ((NOT (LDB-TEST %%CHAOS-CSR-RECEIVE-DONE CSR))

trunk/lisp/lmio1/dplt.lisp

@@ -141 +141 @@
   (UNWIND-PROTECT 
     (PROGN
-      (SETQ STREAM (OPEN (SI:FILE-DEFAULT-FN2 FILE "PLT") '(:IN :FIXNUM :BYTE-SIZE 9.))
+      (SETQ STREAM (OPEN (FUNCALL (FS:FILE-PARSE-NAME FILE)
+                                  ':COPY-WITH-TYPE
+                                  "PLT")
+                         '(:IN :FIXNUM :BYTE-SIZE 9.))
             X-OFFSET 0 Y-OFFSET 0                       ;no offsets initially
             MIN-X  #.(ASH 1 16.)                        ;init to largest and smallest possible
@@ -301 +304 @@
                           (// BINARY-TIME 60.)
                           (\ BINARY-TIME 60.)))
-     (FILE-NAME   (FORMAT NIL "~A:~A; ~A"
-                          (FIRST (SI:FILE-SPREAD-PATHNAME (FUNCALL STREAM ':NAME)))
-                          (SIXBIT-TO-STRING SIXBIT-DIR) (SIXBIT-TO-STRING SIXBIT-FN1)))
+     (FILE-NAME (FUNCALL (FUNCALL STREAM ':FILENAME) ':STRING-FOR-PRINTING))
      (LEFT   (FLEFT FRAME))
      (RIGHT  (FRIGHT FRAME))

trunk/lisp/lmio1/press.lisp

@@ -205 +205 @@
                        (FERROR NIL "~A - cannot connect to DOVER server at AI-CHAOS-11" CONN))
                   (CHAOS:STREAM CONN)))
-            (OPEN (SI:FILE-MERGE-PATHNAMES
-                    HOST-ADDRESS
-                    (FORMAT NIL "MC:.DOVR.;~A >" USER-ID))
+            (OPEN (SI:FILE-PARSE-NAME
+                    HOST-ADDRESS NIL
+                    (SI:FILE-PARSE-NAME (FORMAT NIL "MC:.DOVR.;~A >" USER-ID)))
                   '(:WRITE :FIXNUM :BYTE-SIZE 8)))
         PRESS-CURRENT-RECORD-NUMBER 0

trunk/lisp/lmio1/rfontw.lisp

@@ -42 +42 @@
 ; to avoid any possible package problems.
 
-(declare (special widths-file widths-file-next-word widths-file-pos
-                  code-alist))
+#M (eval-when (compile eval)
+        (defmacro dotimes ((var val) &rest forms)
+                  `(do ((,var ,val (1- ,var))) ((not (> ,var 0))) ,.forms)))
+
+
+(declare (special widths-file code-alist #M widths-file-next-word))
 
 ;Fixnum array (so no number cons) contains -1 or buffered word
@@ -49 +53 @@
        (setq widths-file-next-word (*array nil 'fixnum 1)))
 
-#M (declare (fixnum (next-word) i j k m n wd))
+#M (declare (fixnum (next-word) (widths-file-pos) i j k m n wd))
 
 (eval-when (compile eval)
@@ -61 +65 @@
 ;Get next 16-bit word from widths-file
 (defun next-word ()
-  (setq widths-file-pos (1+ widths-file-pos))
   #M (cond ((minusp (arraycall fixnum widths-file-next-word 0))
             (let ((wd (in widths-file)))
@@ -71 +74 @@
   #Q (funcall widths-file ':tyi "Unexpected EOF on widths file"))
 
+
+(defun widths-file-pos ()
+   #M (- (* 2 (filepos widths-file))
+         (cond ((minusp (arraycall fixnum widths-file-next-word 0)) 0)
+               (t 1)))
+   #Q (funcall widths-file ':read-pointer))
+
 ;2's complement form of next-word
 (defun next-word2 ()
@@ -77 +87 @@
     wd))
 
+             
 (defun bcpl-string (n) ;n = max-length-including-header-byte and is even
   (let ((wd (next-word)))
@@ -131 +142 @@
         (segment-data nil)
         (wd 0))
-    (setq widths-file-pos 0)
  #M (store (arraycall fixnum widths-file-next-word 0) -1)
     (setq wd (next-word))
@@ -169 +179 @@
         ((null segment-data))
       (setq seg (car segment-data))
-      (let ((gap (- (cadddr (cdddr seg)) widths-file-pos)))
+      (let ((gap (- (cadddr (cdddr seg)) (widths-file-pos))))
+        #M (declare (fixnum gap))
         (cond ((minusp gap) (break file-out-of-phase t)))
         (dotimes (i gap) (next-word)))
@@ -283 +294 @@
         family-code tem segment
         (wd 0))
-    (setq widths-file-pos 0)
     (setq wd (next-word))
     ;; Read IXN entries (type 1)

trunk/lisp/lmio1/time.lisp

@@ -332 +332 @@
            (ASET DIG2 STR (1+ I)))))
 
-;;; Some useful strings and accessing functions
-(DEFVAR *DAYS-OF-THE-WEEK* '(("Mon" "Monday")
-                             ("Tue" "Tuesday" "Tues")
-                             ("Wed" "Wednesday")
-                             ("Thu" "Thursday" "Thurs")
-                             ("Fri" "Friday")
-                             ("Sat" "Saturday")
-                             ("Sun" "Sunday")))
+;;; Some useful strings and accessing functions.
+
+;;; Days of the week.  Elements must be (in order):
+;;; (1) Three-letter form.
+;;; (2) Full spelling.
+;;; (3) Middle-length form if any, else NIL.
+;;; (4) Francais.
+;;; (5) Deutsch.
+(DEFVAR *DAYS-OF-THE-WEEK* '(("Mon" "Monday" NIL "Lundi" "Montag")
+                             ("Tue" "Tuesday" "Tues" "Mardi" "Dienstag")
+                             ("Wed" "Wednesday" NIL "Mercredi" "Mittwoch")
+                             ("Thu" "Thursday" "Thurs" "Jeudi" "Donnerstag")
+                             ("Fri" "Friday" NIL "Vendredi" "Freitag")
+                             ("Sat" "Saturday" NIL "Samedi" "Samstag")
+                             ("Sun" "Sunday" NIL "Dimanche" "Sonntag")))
 
 (DEFUN DAY-OF-THE-WEEK-STRING (DAY-OF-THE-WEEK &OPTIONAL (MODE ':LONG) &AUX STRINGS)
@@ -347 +354 @@
     (:LONG (SECOND STRINGS))
     (:MEDIUM (OR (THIRD STRINGS) (FIRST STRINGS)))
+    (:FRENCH (FOURTH STRINGS))
+    (:GERMAN (FIFTH STRINGS))
     (OTHERWISE (FERROR NIL "~S is not a known mode" MODE))))
 
-(DEFVAR *MONTHS* '(("Jan" "January")
-                   ("Feb" "February")
-                   ("Mar" "March")
-                   ("Apr" "April")
-                   ("May" "May")
-                   ("Jun" "June")
-                   ("Jul" "July")
-                   ("Aug" "August")
-                   ("Sep" "September")
-                   ("Oct" "October")
-                   ("Nov" "November")
-                   ("Dec" "December")))
+
+;;; Months of the year:  Elements must be (in order):
+;;; (1) Three-letter form.
+;;; (2) Full spelling.
+;;; (3) Middle-length form if any, else NIL.
+;;; (4) Francais.
+;;; (5) Roman numberals (used in Europe).
+(DEFVAR *MONTHS* '(("Jan" "January" NIL "Janvier" "I" "Januar")
+                   ("Feb" "February" NIL "Fevrier" "II" "Februar")
+                   ("Mar" "March" NIL "Mars" "III" "Maerz")
+                   ("Apr" "April" NIL "Avril" "IV" "April")
+                   ("May" "May" NIL "Mai" "V" "Mai")
+                   ("Jun" "June" NIL "Juin" "VI" "Juni")
+                   ("Jul" "July" NIL "Juillet" "VII" "Juli")
+                   ("Aug" "August" NIL "Aout" "VIII" "August")
+                   ("Sep" "September" "Sept" "Septembre" "IX" "September")
+                   ("Oct" "October" NIL "Octobre" "X" "Oktober")
+                   ("Nov" "November" "Novem" "Novembre" "XI" "November")
+                   ("Dec" "December" "Decem" "Decembre" "XII" "Dezember")))
 
 (DEFUN MONTH-STRING (MONTH &OPTIONAL (MODE ':LONG) &AUX STRINGS)
@@ -367 +383 @@
     (:SHORT (FIRST STRINGS))
     (:LONG (SECOND STRINGS))
+    (:MEDIUM (OR (THIRD STRINGS) (FIRST STRINGS)))
+    (:FRENCH (FOURTH STRINGS))
+    (:ROMAN (FIFTH STRINGS))
+    (:GERMAN (SIXTH STRINGS))
     (OTHERWISE (FERROR NIL "~S is not a known mode" MODE))))
 

trunk/lisp/lmio1/xgp.lisp

@@ -83 +83 @@
                                     (substring date-time 0 midpt)))
      (format q-stream ";Status ~A       LM ~C ~A  1 page        ~A ~%"
-             user-id user-group-affiliation date-time file)
+             user-id fs:user-group-affiliation date-time file)
      (if xgp-delete-scan-file (format q-stream ";DELETE~%"))
      (format q-stream ";SCAN~2%~A~%" file)