;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; File - disks.lisp
;; Description - small sample program for defining disk geometry in
;; order to partition disks etc.
;; Author - Gail Anderson (ga at HELLESVEAN)
;; Created On - Tue Feb 1 20:28:10 2000
;; Last Modified On - Thu Apr 19 19:26:13 2001
;; Last Modified By - Gail Anderson (ga at lostwithiel)
;; Update Count - 252
;; Status - Unknown
;;
;; $Id: disks.lisp,v 1.1.1.1 2002/12/12 02:15:47 colin Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Define a package for internals
(cl:defpackage :disk-geometry
(:nicknames :disks)
(:use :cl)
(:export #:*verbose*
#:disk-geometry
#:define-disk-geometry
#:disk-partition
#:define-disk-partition
#:disk
#:define-disk))
;;; Switch to the new internals package to define classes etc. etc.
(cl:in-package :disk-geometry)
;;; controls whether or not logging information is produced/output is
;;; verbose. set this to nil if you want the program to keep quiet
(defparameter *verbose* t)
;;; stores all the currently defined valid, named disk-geometry instances
(defparameter *defined-geometry-list* '())
;;; stores all the currently defined valid, named disk-partition instances
(defparameter *defined-partition-list* '())
;;; stores all the currently defined valid, named disk instances
(defparameter *defined-disk-list* '())
;;; Top-level class within this package, so that we can
;;; easily find and graph out all the classes defined in the
;;; package, and so on
(defclass disks-package-object ()
())
;;; Generic function for finding and returning an instance of a
;;; General class definition for describing disk geometry. Slot
;;; definitions provide information about the basic disk-geometry;
;;; some slots calculated from others at the time an instance of the
;;; class is created, and another cached the first time it is accessed
;;; (more as an example of how to do this than because this is
;;; necssary, to be honest)
(defclass disk-geometry (disks-package-object)
((nametag
:initform ""
:initarg :nametag
:accessor nametag)
(bytes/sector
:initform 512
:initarg :bytes/sector
:accessor bytes/sector)
(sectors/track
:initform nil
:initarg :sectors/track
:accessor sectors/track)
(tracks/cylinder
:initform nil
:initarg :tracks/cylinder
:accessor tracks/cylinder)
(cylinders
:initform nil
:initarg :cylinders
:accessor cylinders)
(reserve-cylinders
:initform nil
:initarg :reserve-cylinders
:accessor reserve-cylinders)
(sectors/cylinder
:initform nil
:accessor sectors/cylinder)
(bytes/cylinder
:initform nil
:accessor get-bytes/cylinder)
(accessible-cylinders
:initform nil
:accessor accessible-cylinders))
(:documentation
"Top-level class definition for defining disk geometry. Slots are:
nametag: (optional) nametag for this instance
bytes/sector: number of bytes per sector
sectors/track: number of sectors per track
tracks/cylinder: number of tracks per cylinder
sectors/cylinder: number of sectors per cylinder
(calculated from sectors/track and sectors/cylinder when
an instance of the class is created)
bytes/cylinder: number of bytes per cylinder
(calculated and cached first time it is accessed)
cylinders: total number of cylinders
reserve-cylinders: number of reserved cylinders
accessible-cylinders: number of accessible (usable) cylinders
(the difference between cylinders and reserve-cylinders;
calculated when an instance of the class is created)"))
;;; After method for initialize-instance, which
;;; 1) checks whether the slot values provided in the instance
;;; definition are reasonable, signalling an error or a warning if
;;; appropriate;
;;; 2) calculates sectors/cylinder and accessible/cylinders from
;;; user-provided slot values
(defmethod initialize-instance :after ((dg disk-geometry) &key)
(check-slot-value dg 'nametag 'string "a string")
(if (and *verbose* (= (length (nametag dg)) 0))
(warn "Initialising disk-geometry instance ~S with no nametag" dg))
(check-slot-value dg 'bytes/sector '(integer 1 *)
"an integer greater than 0, usually 512")
(if (and *verbose* (not (= (bytes/sector dg) 512)))
(warn "Bytes/sector non-standard (usually 512)"))
(check-slot-value dg 'sectors/track '(integer 1 *)
"an integer greater than 0")
(check-slot-value dg 'tracks/cylinder '(integer 1 *)
"an integer greater than 0")
(check-slot-value dg 'cylinders '(integer 1 *)
"an integer greater than 0")
(check-slot-value dg 'reserve-cylinders '(integer 1 *)
"a non-negative integer less than the total cylinders"
#'(lambda (n)
(< n (cylinders dg))))
(setf (sectors/cylinder dg) (* (sectors/track dg) (tracks/cylinder dg)))
(setf (accessible-cylinders dg) (- (cylinders dg) (reserve-cylinders dg)))
(if *verbose*
(format t "New instance of disk-geometry created.~%" dg)))
;;; Function which calculates and caches bytes/cylinder the first time
;;; it is called on an instance of disk-geometry
(defgeneric bytes/cylinder (dg))
(defmethod bytes/cylinder ((dg disk-geometry))
(or (get-bytes/cylinder dg)
(setf (get-bytes/cylinder dg)
(* (bytes/sector dg)
(sectors/cylinder dg)))))
;;; Top-level defining form for disk-geometry
(defmacro define-disk-geometry (&optional name &rest slot-specifications)
`(let ((dg (apply #'make-instance 'disk-geometry
:nametag ',name ',slot-specifications)))
(if *verbose*
(print-details dg))
(push (cons (nametag dg) dg) *defined-geometry-list*)
(or (nametag dg) t)))
;;;; function which returns a disk-geometry instance given its nametag
(defun get-geometry (nametag &key (list *defined-geometry-list*))
(cdr (assoc nametag list :test #'equal)))
;;; function which maps a function over all instances of disk-geometry
(defun map-over-geometry-list (func &key (list *defined-geometry-list*))
(mapc #'(lambda (ge)
(funcall func (cdr ge)))
list)
t)
;;; General class definition for describing a partition map
(defclass disk-partition (disks-package-object)
((nametag
:initform ""
:initarg :nametag
:accessor nametag)
(slice0
:initform nil
:initarg :slice0
:accessor slice0)
(slice1
:initform nil
:initarg :slice1
:accessor slice1)
(slice2
:initform nil
:initarg :slice2
:accessor slice2)
(slice3
:initform nil
:initarg :slice3
:accessor slice3)
(slice4
:initform nil
:initarg :slice4
:accessor slice4)
(slice5
:initform nil
:initarg :slice5
:accessor slice5)
(slice6
:initform nil
:initarg :slice6
:accessor slice6)
(slice7
:initform nil
:initarg :slice7
:accessor slice7))
(:documentation
"Top-level class definition for defining disk partition maps. Slots are:
nametag: (optional) nametag for this instance
slice0: start cyl and #-cyls of slice 0
slice1: start cyl and #-cyls of slice 1
slice2: start cyl and #-cyls of slice 2
slice3: start cyl and #-cyls of slice 3
slice4: start cyl and #-cyls of slice 4
slice5: start cyl and #-cyls of slice 5
slice6: start cyl and #-cyls of slice 6
slice7: start cyl and #-cyls of slice 7"))
;;; After method for initialize-instance, which checks whether the
;;; slot values provided in the instance definition are reasonable, and
;;; also carry a simple sanity check on the data. Other possible
;;; checks (possible extensions?) include: check for overlapping slices;
;;; check for unused space.
(defmethod initialize-instance :after ((dp disk-partition) &key)
(let ((slices '(slice0 slice1 slice2 slice3 slice4 slice5 slice6 slice7)))
(check-slot-value dp 'nametag 'string "a string")
(if (and *verbose* (= (length (nametag dp)) 0))
(warn "Initialising disk-partition instance ~S with no nametag" dp))
(mapc
#'(lambda (sl)
(check-slot-value
dp sl 'list "a list of two integers (start-cyl #-cyls)"
#'(lambda (slsp)
(and (listp slsp)
(typep (first slsp) '(integer 0 *))
(typep (second slsp) '(integer 0 *))))))
slices)
(if (and (slice2 dp)
(> (apply #'+ (remove nil
(mapcar #'(lambda (sl)
(second (slot-value dp sl)))
(remove 'slice2 slices))))
(second (slice2 dp))))
(warn "Total allocated space bigger than slice 2 (whole of disk)"))))
(defmacro define-disk-partition (&optional name &rest slot-specifications)
`(let ((dp (apply #'make-instance 'disk-partition
:nametag ',name ',slot-specifications)))
(if *verbose*
(print-details dp))
(push (cons (nametag dp) dp) *defined-partition-list*)
(or (nametag dp) t)))
;;;; function which returns a disk-partition instance given its nametag
(defun get-partition (nametag &key (list *defined-partition-list*))
(cdr (assoc nametag list :test #'equal)))
;;; function which maps a function over all instances of disk-partition
(defun map-over-partition-list (func &key (list *defined-partition-list*))
(mapc #'(lambda (ge)
(funcall func (cdr ge)))
list)
t)
;;; General class definition for describing a disk
(defclass disk (disks-package-object)
((nametag
:initform ""
:initarg :nametag
:accessor nametag)
(geometry
:initform nil
:initarg :geometry
:accessor geometry)
(partition
:initform nil
:initarg :partition
:accessor partition))
(:documentation
"Top-level class for defining disks. Slots are:
nametag: (optional) nametag for this instance
geometry: instance of disk-geometry which describes this physical disk
partition: instance of disk-partition which specifies the partition map
to use for this disk."))
;;; After method for initialize-instance, which checks whether the
;;; slot values provided are reasonable. This could be extended to
;;; check whether the instances specified are suitable for use
;;; together: e.g. does the partition map specify more cylinders than
;;; provided by this physical disk, according to the slot values of
;;; the disk-geometry instance?
(defmethod initialize-instance :after ((dd disk) &key)
(check-slot-value dd 'nametag 'string "a string")
(check-slot-value dd 'geometry 'disk-geometry
"an instance of disk-geometry")
(check-slot-value dd 'partition 'disk-partition
"an instance of disk-partition"))
;;; Top-level defining form for disk
(defmacro define-disk (&optional name geometry-name partition-name)
`(let* ((geom
(or (and (not (null ,geometry-name)) (get-geometry ,geometry-name))
(progn
(format t "Defining new disk geometry with nametag ~S:~%"
,geometry-name)
(get-geometry (define-disk-geometry ,geometry-name)))))
(part
(or (and (not (null ,partition-name)) (get-partition ,partition-name))
(progn
(format t "Defining new disk partition with nametag ~S:~%"
,partition-name)
(get-partition (define-disk-partition ,partition-name)))))
(dd (funcall #'make-instance 'disk
:nametag ',name :geometry geom :partition part)))
(if *verbose*
(print-details dd))
(push (cons (nametag dd) dd) *defined-disk-list*)
(or (nametag dd) t)))
;;; function which returns a disk instance given its nametag
(defun get-disk (nametag &key (list *defined-disk-list*))
(cdr (assoc nametag list :test #'equal)))
;;; function which maps a function over all instances of disk
(defun map-over-disk-list (func &key (list *defined-disk-list*))
(mapc #'(lambda (di)
(funcall func (cdr di)))
list)
t)
;;; general function which error/warning checks slot values, and
;;; prompts user to enter values for mandatory attributes which we
;;; can't easily default, if necessary
(defun check-slot-value (instance slot-name type type-desc &optional test)
(flet ((check-value (inst slot type)
(and (typep (slot-value inst slot) type)
(or (null test) (funcall test (slot-value inst slot))))))
(do* ((res
(check-value instance slot-name type)
(progn
(let ((slot-value (slot-value instance slot-name)))
(format t "Unacceptable value (~S) for slot ~A in ~S object~%"
slot-value slot-name (type-of instance))
(format t "~2TPlease enter ~A now: " type-desc))
(setf (slot-value instance slot-name) (read))
(check-value instance slot-name type))))
(res))))
;;; Output routines
(defgeneric print-details (dg &key (stream *standard-output*)))
(defmethod print-details ((dg disk-geometry) &key (stream *standard-output*))
(format stream "~3TDetails of ~S~%" dg)
(format stream "~5TNametag: ~S~%" (nametag dg))
(format stream "~5TNumber of bytes/sector: ~20D~%"
(bytes/sector dg))
(format stream "~5TNumber of sectors/track: ~20D~%"
(sectors/track dg))
(format stream "~5TNumber of tracks/cylinder: ~20D~%"
(tracks/cylinder dg))
(format stream "~5TNumber of bytes/cylinder: ~20D~%"
(bytes/cylinder dg))
(format stream "~5TNumber of cylinders: ~20D~%"
(cylinders dg))
(format stream "~5TNumber of reserved cylinders: ~20D~%"
(reserve-cylinders dg))
(format stream "~5TNumber of accessible cylinders: ~20D~%~%"
(accessible-cylinders dg))
(format stream "~%"))
(defmethod print-details ((dp disk-partition) &key (stream *standard-output*))
(flet ((print-slice (slicename slicespec)
(format stream "~5T~A start-cyl: ~D #-cyls: ~D~%"
slicename (first slicespec) (second slicespec))))
(format stream "~3TDetails of ~S~%" dp)
(format stream "~5TNametag: ~S~%" (nametag dp))
(print-slice "Slice 0" (slice0 dp))
(print-slice "Slice 1" (slice1 dp))
(print-slice "Slice 2" (slice2 dp))
(print-slice "Slice 3" (slice3 dp))
(print-slice "Slice 4" (slice4 dp))
(print-slice "Slice 5" (slice5 dp))
(print-slice "Slice 6" (slice6 dp))
(print-slice "Slice 7" (slice7 dp))
(format stream "~%")))
(defmethod print-details ((dd disk) &key (stream *standard-output*))
(format stream "Details of ~S~%" dd)
(format stream "~2TNametag: ~S~%" (nametag dd))
(format stream "~2TGeometry~%")
(print-details (geometry dd))
(format stream "~2TPartition table~%")
(print-details (partition dd))
(format stream "~%"))
(defun print-geometry-list (&key (list *defined-geometry-list*)
(stream *standard-output*))
(map-over-geometry-list #'(lambda (l)
(print-details l :stream stream))
:list list))
(defun print-partition-list (&key (list *defined-partition-list*)
(stream *standard-output*))
(map-over-partition-list #'(lambda (l)
(print-details l :stream stream))
:list list))