mirror of
https://github.com/PDP-10/its.git
synced 2026-02-06 00:24:41 +00:00
111 lines
3.2 KiB
Common Lisp
111 lines
3.2 KiB
Common Lisp
;;;;;;;;;;;;;;;;;;; -*- Mode: Lisp; Package: Macsyma -*- ;;;;;;;;;;;;;;;;;;;
|
|
;;; (c) Copyright 1980 Massachusetts Institute of Technology ;;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(macsyma-module opshin macro)
|
|
|
|
;;; GJC 7:24pm Saturday, 20 September 1980
|
|
|
|
;;; For parsing standard option lists.
|
|
|
|
;;; <Option-header> ::= <name> | (<name> . <option-list>)
|
|
;;; <option-list> ::= (<option-slot> . <option-list>) | ()
|
|
;;; <option-slot> ::= <name> | (<name>) | (<name> <value>)
|
|
|
|
(DEFVAR OPTION-MASTER)
|
|
|
|
(DEFUN PARSE-OPTION-HEADER (OPTION-MASTER HEADER)
|
|
(PARSE-OPTION OPTION-MASTER (COND ((ATOM HEADER)
|
|
`((NAME ,HEADER)))
|
|
((ATOM (CAR HEADER))
|
|
`((NAME ,(CAR HEADER))
|
|
,@(CDR HEADER)))
|
|
(T
|
|
(OPTION-PARSE-ERROR
|
|
"bad name designation in header."
|
|
HEADER)))))
|
|
|
|
(DEFUN PARSE-OPTION (OPTION-MASTER LIST)
|
|
(PARSE-OPTION-SUB (OR (GET OPTION-MASTER 'OPTION-ACTIONS)
|
|
(ERROR "has no option actions."
|
|
OPTION-MASTER
|
|
'FAIL-ACT))
|
|
(COPY-TOP-LEVEL LIST) NIL))
|
|
|
|
(DEFUN OPTION-PARSE-ERROR (MESS THING)
|
|
(FORMAT MSGFILES "~&; Error parsing option for ~A" OPTION-MASTER)
|
|
(ERROR MESS THING 'FAIL-ACT))
|
|
|
|
(DEFUN STANDARD-T (DONE NAME)
|
|
(CONS (CONS NAME T) DONE))
|
|
|
|
(DEFUN STANDARD-VAL (DONE NAME VAL)
|
|
(CONS (CONS NAME VAL) DONE))
|
|
|
|
(DEFUN STANDARD-%%EMPTY%% (DONE NAME)
|
|
(CONS (CONS NAME '%%EMPTY%%) DONE))
|
|
|
|
(DEFSTRUCT (OPTION-ACTION CONC-NAME)
|
|
NAME
|
|
(DOCUMENT "")
|
|
(IF-ATOM #'STANDARD-T)
|
|
(IF-VAL #'STANDARD-VAL)
|
|
(IF-NOT #'STANDARD-%%EMPTY%%))
|
|
|
|
(DEFUN PARSE-OPTION-SUB (OPTION-ACTIONS LIST DONE)
|
|
(COND ((NULL OPTION-ACTIONS)
|
|
(IF (NULL LIST) DONE
|
|
(OPTION-PARSE-ERROR "unknown option." list)))
|
|
(T
|
|
(LET* ((ACTION (CAR OPTION-ACTIONS))
|
|
(NAME (OPTION-ACTION-NAME ACTION))
|
|
(SLOT (GET-OPTION-SLOT NAME LIST)))
|
|
(PARSE-OPTION-SUB
|
|
(CDR OPTION-ACTIONS)
|
|
(DELETE SLOT LIST)
|
|
(COND ((null slot)
|
|
(FUNCALL (OPTION-ACTION-IF-NOT ACTION)
|
|
DONE NAME))
|
|
((ATOM SLOT)
|
|
(FUNCALL (OPTION-ACTION-IF-ATOM ACTION)
|
|
DONE NAME))
|
|
(T
|
|
(CASEQ (LENGTH SLOT)
|
|
(1
|
|
(FUNCALL (OPTION-ACTION-IF-VAL ACTION)
|
|
DONE NAME NIL))
|
|
(2
|
|
(FUNCALL (OPTION-ACTION-IF-VAL ACTION)
|
|
DONE NAME (CADR SLOT)))
|
|
(T
|
|
(OPTION-PARSE-ERROR
|
|
"bad option spec." slot))))))))))
|
|
|
|
(DEFUN GET-OPTION-SLOT (NAME LIST)
|
|
(COND ((NULL LIST) NIL)
|
|
((ATOM (CAR LIST))
|
|
(IF (EQ NAME (CAR LIST))
|
|
(CAR LIST)
|
|
(GET-OPTION-SLOT NAME (CDR LIST))))
|
|
((ATOM (CAAR LIST))
|
|
(IF (EQ NAME (CAAR LIST))
|
|
(CAR LIST)
|
|
(GET-OPTION-SLOT NAME (CDR LIST))))
|
|
('ELSE
|
|
(OPTION-PARSE-ERROR "bad option spec name." (CAAR LIST)))))
|
|
|
|
(COMMENT |example|
|
|
(DEF-OPTION FOO
|
|
(NAME)
|
|
(BAZ
|
|
DOCUMENT "Stupid option to use."
|
|
IF-ATOM (LAMBDA (FOO BAR) (BAZ FOO BAR)))))
|
|
|
|
(DEFMACRO DEF-OPTION (NAME &REST OPTION)
|
|
`(PUTPROP ',NAME
|
|
(LIST ,@(MAPCAR #'(LAMBDA (U)
|
|
`(MAKE-OPTION-ACTION
|
|
NAME ',(IF (ATOM U) U (CAR U))
|
|
,@(IF (ATOM U) NIL (CDR U))))
|
|
OPTION))
|
|
'OPTION-ACTIONS)) |