255 lines
8.4 KiB
Scheme
255 lines
8.4 KiB
Scheme
;; Copyright (c) 2001-2003 by Norbert Freudemann, David Frese
|
|
|
|
;; *** x errors ******************************************************
|
|
|
|
(define-record-type x-error :x-error
|
|
(make-x-error display serial code major-opcode minor-opcode resource-id text)
|
|
x-error?
|
|
(display x-error:display)
|
|
(serial x-error:serial)
|
|
(code x-error:code)
|
|
(major-opcode x-error:major-opcode)
|
|
(minor-opcode x-error:minor-opcode)
|
|
(resource-id x-error:resource-id)
|
|
(text x-error:text))
|
|
|
|
(define-exported-binding "scx-x-error" :x-error)
|
|
|
|
(define-enumerated-type error-code :error-code
|
|
error-code? error-codes error-code-name error-code-index
|
|
(success bad-request bad-value bad-window bad-pixmap bad-atom
|
|
bad-cursor bad-font bad-match bad-drawable bad-access bad-alloc
|
|
bad-color bad-gc bad-id-choice bad-name bad-length bad-implementation))
|
|
|
|
(define-exported-binding "scx-error-code" :error-code)
|
|
(define-exported-binding "scx-error-codes" error-codes)
|
|
|
|
;; *** error exceptions **********************************************
|
|
|
|
(define (opcode->string oc)
|
|
(case oc
|
|
((1) "X_CreateWindow")
|
|
((2) "X_ChangeWindowAttributes")
|
|
((3) "X_GetWindowAttributes")
|
|
((4) "X_DestroyWindow")
|
|
((5) "X_DestroySubwindows")
|
|
((6) "X_ChangeSaveSet")
|
|
((7) "X_ReparentWindow")
|
|
((8) "X_MapWindow")
|
|
((9) "X_MapSubwindows")
|
|
((10) "X_UnmapWindow")
|
|
((11) "X_UnmapSubwindows")
|
|
((12) "X_ConfigureWindow")
|
|
((13) "X_CirculateWindow")
|
|
((14) "X_GetGeometry")
|
|
((15) "X_QueryTree")
|
|
((16) "X_InternAtom")
|
|
((17) "X_GetAtomName")
|
|
((18) "X_ChangeProperty")
|
|
((19) "X_DeleteProperty")
|
|
((20) "X_GetProperty")
|
|
((21) "X_ListProperties")
|
|
((22) "X_SetSelectionOwner")
|
|
((23) "X_GetSelectionOwner")
|
|
((24) "X_ConvertSelection")
|
|
((25) "X_SendEvent")
|
|
((26) "X_GrabPointer")
|
|
((27) "X_UngrabPointer")
|
|
((28) "X_GrabButton")
|
|
((29) "X_UngrabButton")
|
|
((30) "X_ChangeActivePointerGrab")
|
|
((31) "X_GrabKeyboard")
|
|
((32) "X_UngrabKeyboard")
|
|
((33) "X_GrabKey")
|
|
((34) "X_UngrabKey")
|
|
((35) "X_AllowEvents")
|
|
((36) "X_GrabServer")
|
|
((37) "X_UngrabServer")
|
|
((38) "X_QueryPointer")
|
|
((39) "X_GetMotionEvents")
|
|
((40) "X_TranslateCoords")
|
|
((41) "X_WarpPointer")
|
|
((42) "X_SetInputFocus")
|
|
((43) "X_GetInputFocus")
|
|
((44) "X_QueryKeymap")
|
|
((45) "X_OpenFont")
|
|
((46) "X_CloseFont")
|
|
((47) "X_QueryFont")
|
|
((48) "X_QueryTextExtents")
|
|
((49) "X_ListFonts")
|
|
((50) "X_ListFontsWithInfo")
|
|
((51) "X_SetFontPath")
|
|
((52) "X_GetFontPath")
|
|
((53) "X_CreatePixmap")
|
|
((54) "X_FreePixmap")
|
|
((55) "X_CreateGC")
|
|
((56) "X_ChangeGC")
|
|
((57) "X_CopyGC")
|
|
((58) "X_SetDashes")
|
|
((59) "X_SetClipRectangles")
|
|
((60) "X_FreeGC")
|
|
((61) "X_ClearArea")
|
|
((62) "X_CopyArea")
|
|
((63) "X_CopyPlane")
|
|
((64) "X_PolyPoint")
|
|
((65) "X_PolyLine")
|
|
((66) "X_PolySegment")
|
|
((67) "X_PolyRectangle")
|
|
((68) "X_PolyArc")
|
|
((69) "X_FillPoly")
|
|
((70) "X_PolyFillRectangle")
|
|
((71) "X_PolyFillArc")
|
|
((72) "X_PutImage")
|
|
((73) "X_GetImage")
|
|
((74) "X_PolyText8")
|
|
((75) "X_PolyText16")
|
|
((76) "X_ImageText8")
|
|
((77) "X_ImageText16")
|
|
((78) "X_CreateColormap")
|
|
((79) "X_FreeColormap")
|
|
((80) "X_CopyColormapAndFree")
|
|
((81) "X_InstallColormap")
|
|
((82) "X_UninstallColormap")
|
|
((83) "X_ListInstalledColormaps")
|
|
((84) "X_AllocColor")
|
|
((85) "X_AllocNamedColor")
|
|
((86) "X_AllocColorCells")
|
|
((87) "X_AllocColorPlanes")
|
|
((88) "X_FreeColors")
|
|
((89) "X_StoreColors")
|
|
((90) "X_StoreNamedColor")
|
|
((91) "X_QueryColors")
|
|
((92) "X_LookupColor")
|
|
((93) "X_CreateCursor")
|
|
((94) "X_CreateGlyphCursor")
|
|
((95) "X_FreeCursor")
|
|
((96) "X_RecolorCursor")
|
|
((97) "X_QueryBestSize")
|
|
((98) "X_QueryExtension")
|
|
((99) "X_ListExtensions")
|
|
((100) "X_ChangeKeyboardMapping")
|
|
((101) "X_GetKeyboardMapping")
|
|
((102) "X_ChangeKeyboardControl")
|
|
((103) "X_GetKeyboardControl")
|
|
((104) "X_Bell")
|
|
((105) "X_ChangePointerControl")
|
|
((106) "X_GetPointerControl")
|
|
((107) "X_SetScreenSaver")
|
|
((108) "X_GetScreenSaver")
|
|
((109) "X_ChangeHosts")
|
|
((110) "X_ListHosts")
|
|
((111) "X_SetAccessControl")
|
|
((112) "X_SetCloseDownMode")
|
|
((113) "X_KillClient")
|
|
((114) "X_RotateProperties")
|
|
((115) "X_ForceScreenSaver")
|
|
((116) "X_SetPointerMapping")
|
|
((117) "X_GetPointerMapping")
|
|
((118) "X_SetModifierMapping")
|
|
((119) "X_GetModifierMapping")
|
|
((127) "X_NoOperation")
|
|
(else "unknown")))
|
|
|
|
(define (x-error->string e)
|
|
(string-append (x-error:text e) "\n"
|
|
" Major Opcode: " (number->string (x-error:major-opcode e))
|
|
" (" (opcode->string (x-error:major-opcode e)) ")\n"
|
|
" Resource ID: " (number->string (x-error:resource-id e))))
|
|
|
|
(define-condition-type 'x-warning '(warning))
|
|
(define x-warning? (condition-predicate 'x-warning))
|
|
(define (x-warning:x-error w)
|
|
(cadr (condition-stuff w)))
|
|
(define (signal-x-warning x-error)
|
|
(signal 'x-warning (x-error->string x-error) x-error))
|
|
|
|
;; Call synchronize to have the warnings signaled where they belong to.
|
|
|
|
(define (use-x-error-warnings!)
|
|
(set-error-handler! (lambda (display error)
|
|
(signal-x-warning error))))
|
|
|
|
;; *** error-queue ***************************************************
|
|
|
|
;; Interface:
|
|
;; (use-x-error-queue!) returns a thunk that returns the most recent queue
|
|
;; element.
|
|
;; (empty-x-error-queue? q) return #t only for the initial queue.
|
|
;; (next-x-error-queue q) returns the next queue element, blocks if necessary.
|
|
;; (x-error-queue:this q) returns the x-error of that queue.
|
|
|
|
(define (use-x-error-queue!) ;; exp
|
|
(let* ((most-recent-x-error-queue empty-x-error-queue)
|
|
(handler (lambda (display error)
|
|
(set-next-x-error-queue! most-recent-x-error-queue
|
|
(make-x-error-queue error))
|
|
(set! most-recent-x-error-queue
|
|
(next-x-error-queue most-recent-x-error-queue)))))
|
|
(set-error-handler! handler)
|
|
(lambda () most-recent-x-error-queue)))
|
|
|
|
(define-record-type x-error-queue :x-error-queue
|
|
(really-make-x-error-queue this next)
|
|
x-error-queue?
|
|
(this x-error-queue:this)
|
|
(next really-next-x-error-queue really-set-next-x-error-queue!))
|
|
|
|
(define (make-x-error-queue error)
|
|
(really-make-x-error-queue error (make-placeholder)))
|
|
|
|
(define empty-x-error-queue (make-x-error-queue #f))
|
|
(define (empty-x-error-queue? obj)
|
|
(eq? obj empty-x-error-queue))
|
|
|
|
(define (next-x-error-queue x-error-queue)
|
|
(placeholder-value (really-next-x-error-queue x-error-queue)))
|
|
|
|
(define (set-next-x-error-queue! x-error-queue next-x-error-queue)
|
|
(placeholder-set! (really-next-x-error-queue x-error-queue)
|
|
next-x-error-queue))
|
|
|
|
;; *** default error handlers ****************************************
|
|
|
|
(define *x-error-handler* #f)
|
|
(define-exported-binding "internal-x-error-handler" *x-error-handler*)
|
|
|
|
(define (set-error-handler! handler)
|
|
(let ((old-handler *x-error-handler*))
|
|
(set! *x-error-handler* handler)
|
|
old-handler))
|
|
|
|
;(import-lambda-definition %set-error-handler (handler)
|
|
; "scx_Set_Error_Handler")
|
|
|
|
;(import-lambda-definition call-c-error-handler (pointer display event)
|
|
; "scx_Call_C_Error_Handler")
|
|
|
|
;(define (set-error-handler! handler)
|
|
; (let ((res (%set-error-handler handler)))
|
|
; (if (number? res)
|
|
; (lambda (display event) (call-c-error-handler (res display event)))
|
|
; res)))
|
|
|
|
(import-lambda-definition get-error-text (display code)
|
|
"scx_Get_Error_Text")
|
|
|
|
(import-lambda-definition get-error-database-text
|
|
(display name message default-string)
|
|
"scx_Get_Error_Database_Text")
|
|
|
|
;(import-lambda-definition %set-io-error-handler (handler)
|
|
; "scx_Set_IO_Error_Handler")
|
|
|
|
(define *x-fatal-error-handler* #f)
|
|
(define-exported-binding "internal-x-fatal-error-handler"
|
|
*x-fatal-error-handler*)
|
|
|
|
(define (set-fatal-error-handler! handler)
|
|
(let ((old-handler *x-fatal-error-handler*))
|
|
(set! *x-fatal-error-handler* handler)
|
|
old-handler))
|
|
|
|
;; *** The default is to use warnings ********************************
|
|
|
|
(use-x-error-warnings!)
|